VBA-BackupExcelFileVer004

(this code is free to use, tested, works properly - click here to get the code)

Option Explicit
'-----------------insert into "ThisWorkbook" module(start)---------------
'Private Sub Workbook_Open()
'blnReleaseCollection = False
'    MsgBox "Auto-Backup active in background:" & vbCrLf _
'        & " - every 15 mins" & vbCrLf _
'        & " - after each file save"
'Call BackupExcelFileVer004.BackupTimesCollectionInitialize
'Call BackupExcelFileVer004.ScheduleBackup
'End Sub
'Private Sub Workbook_AfterSave(ByVal Success As Boolean)
'    Call BackupExcelFileVer004.BackupOnFileSave
'    If blnReleaseCollection Then
'        Call BackupExcelFileVer004.CancelAllScheduledBackups
'    End If
'End Sub
'Private Sub Workbook_BeforeClose(Cancel As Boolean)
'    blnReleaseCollection = True
'    Call BackupExcelFileVer004.CancelAllScheduledBackups
'End Sub
'-----------------insert into "ThisWorkbook" module(end)-----------------
'
'
'------------------------------------
'Software Name: BackupExcelFileVer004
'Description: automated backup file creation _
              - every 15 mins _
              - after each file save (includes on file close)
'License: Freeware
'Date of creation: 2024-05-26
'Author: Gabriel Kovacs, linkedin.com/in/gabrielkovacsprogrammer
'------------------------------------
Private blnBackupOnFileSave As Boolean
Public blnReleaseCollection As Boolean
Public colBackupTimes As Collection
Private intKeepOnBackupYesNo As Integer

Sub BackupOnFileSave()
    blnBackupOnFileSave = True
    If Not colBackupTimes Is Nothing Then
        Call BackupExcelFileVer004.CancelAllScheduledBackups
    End If
    Call BackupExcelFileVer004.BackupWorkbook
            
    'reschedule next auto-backup
    Call BackupExcelFileVer004.BackupTimesCollectionInitialize
    Call BackupExcelFileVer004.ScheduleBackup
End Sub
Sub AutoBackupWorkbook()
    blnBackupOnFileSave = False
    If Not colBackupTimes Is Nothing Then
        Call BackupExcelFileVer004.CancelAllScheduledBackups
    End If
    
    Call BackupExcelFileVer004.BackupWorkbook

        If intKeepOnBackupYesNo = 7 Then 'vbNo
            'cancel auto-backup mode
            BackupExcelFileVer004.CancelAllScheduledBackups
            If Not colBackupTimes Is Nothing Then Set colBackupTimes = Nothing
            MsgBox "Auto-Backup Disabled.", vbExclamation, "Backup"
        
        Else
            'reschedule next auto-backup
            Call BackupExcelFileVer004.BackupTimesCollectionInitialize
            Call BackupExcelFileVer004.ScheduleBackup
        End If
End Sub
Sub BackupWorkbook()
Dim intBackupYesNo As Integer
Dim wbCurrentFile As Workbook

Set wbCurrentFile = ThisWorkbook

On Error GoTo Line_ErrorHandler

    If blnBackupOnFileSave Then
        'skip asking the user
        intBackupYesNo = vbYes
        GoTo Line_CreateBackup
    End If

'    'ask the user if a backup file should be created
'    intBackupYesNo = MsgBox("Create backup?", vbYesNo + vbQuestion, "Backup")
    intBackupYesNo = MsgBox("Create backup?" & vbCrLf _
                            & "(" & wbCurrentFile.Name & ")", vbYesNo + vbQuestion, "Backup")

    'reset the MsgBox return value _
     each time this subroutine is called
    intKeepOnBackupYesNo = 0

Line_CreateBackup:
    If intBackupYesNo = vbYes Then

        Dim strBackupPath As String
        Dim strFileName As String
        Dim intPeriodPosition As Integer
        Const lngFileMaxNumber As Long = 200
        Dim lngFileCount As Long
        Dim strTemporary As String

        'check if the workbook is saved (has a path)
        If wbCurrentFile.Path = "" Then
            MsgBox "Please save the workbook before creating a backup."
            Call BackupExcelFileVer004.CancelAllScheduledBackups
            GoTo Line_ReleaseMemory
        End If

        'find the periods position
        intPeriodPosition = InStrRev(wbCurrentFile.Name, ".")

        'set the backup path in the same directory as the workbook
        strBackupPath = wbCurrentFile.Path & "\Backup_" & Left(wbCurrentFile.Name, intPeriodPosition - 1) & "\"

        'create a file name with a time stamp
        strFileName = "Backup_" & Format(Now(), "yyyy-mm-dd_hh-mm-ss") & "_" & wbCurrentFile.Name

        'create backup directory if it doesn't exist
        If Dir(strBackupPath, vbDirectory) = "" Then
            MkDir strBackupPath
        End If

        'save a backup copy of the workbook
        wbCurrentFile.SaveCopyAs strBackupPath & strFileName
        MsgBox "Backup created.", vbInformation, "Backup"

        'count files in backup folder
        strTemporary = Dir(strBackupPath & "Backup_*.*")
        While strTemporary <> ""
            lngFileCount = lngFileCount + 1
            strTemporary = Dir
        Wend
        If lngFileCount > lngFileMaxNumber Then
            MsgBox "Too many files in Backup folder (" & lngFileCount & ")." & vbCrLf _
                & "Please reduce them manually to optimal 100."
        End If

        GoTo Line_ReleaseMemory

    ElseIf intBackupYesNo = vbNo Then
        'ask the user whether to keep automatic backup system running
        intKeepOnBackupYesNo = MsgBox("Keep Auto-Backup Running?", vbYesNo, "Backup")
        GoTo Line_ReleaseMemory
    End If

Line_ErrorHandler:
    MsgBox "An error occurred: " & Err.Description, vbCritical, "Error"

Line_ReleaseMemory:
    If Not wbCurrentFile Is Nothing Then Set wbCurrentFile = Nothing
On Error GoTo 0
End Sub
Sub BackupTimesCollectionInitialize()
    Set colBackupTimes = New Collection
End Sub
Sub ScheduleBackup()
Dim dblScheduledTime As Double
    'schedule BackupWorkbook procedure to run 15 minutes from now
    dblScheduledTime = Now + TimeValue("00:15:00")
'    dblScheduledTime = Now + TimeValue("00:00:20") 'short time: only for testing
    Application.OnTime dblScheduledTime, "AutoBackupWorkbook"
    'add an item into collection
    colBackupTimes.Add dblScheduledTime
End Sub
Sub CancelAllScheduledBackups()
    Dim varT As Variant
    If Not colBackupTimes Is Nothing Then
        For Each varT In colBackupTimes
            On Error Resume Next
                Application.OnTime varT, "AutoBackupWorkbook", schedule:=False
            On Error GoTo 0
        Next varT
    End If
    'release memory
    Set colBackupTimes = Nothing
End Sub