CODEWITHSUNDEEP
excelvba7
MoDamEr X
MoDamEr X

Reputation: 11

Save a backup when closing a UserForm

I wrote code to save a backup when closing a UserForm.
It works while the workbook is visible or when I click the save button.

Code for Workbook_BeforeSave.

Privat sub Workbook_BeforeSave(byvale SaveAsUI as Boolean, Cancel as Boolean) 

If MsgBox "some text to inform the user" then

   Save_Backup

End if
End sub

Code for Save_Backup

Public sub Save_Backup() 

Dim FileName as String 
Dim WbSource as Workbook 
Dim Backup_Folder_Path As String 

On error resume next 
MkDir thisWorkbook.path & "\BackUp" 
Backup_Folder_Path = thisWorkbook.path & "\BackUp"  

On error GoTo 0
Set WbSource = thisWorkbook

FileName = replace(WbSource.Name, "." ,format(Now(), "ddmmyyyy_hhmmss AM/PM."))

WbSource.save
WbSource.Activate
ActiveWorkbook.SaveCopyAs FileName:= Backup_Folder_Path & "\" & FileName 

Set WbSource = Nothing

End Sub

When I check the Backup folder there are no files.

But after closing the userForm and the application is visible, when I save the workbook the backup is done and I can see files in the Backup folder.

Upvotes: 1

Views: 50

Answers (1)

VBasic2008
VBasic2008

Reputation: 55073

A Workbook BeforeSave: Create a Backup of a Workbook on Every Save

Workbook Module (ThisWorkbook)

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    CreateWorkbookBackup Me, True
End Sub

Standard Module, e.g. Module1

Sub CreateWorkbookBackup(wb As Workbook, Optional ShowMessages As Boolean = False)
    Const PROC_TITLE As String = "Create Workbook Backup"
    On Error GoTo ClearError
    
    ' Build the destination path.
    Dim dFolderPath As String: dFolderPath = wb.Path
    If Len(wb.Path) = 0 Then
        If ShowMessages Then
            MsgBox "Cannot create a copy of a never saved workbook!", _
                vbExclamation, PROC_TITLE
            Exit Sub
        End If
    End If
    dFolderPath = dFolderPath & Application.PathSeparator & "Backup"
    
    ' Create the destination folder.
    On Error Resume Next ' prevent error if the folder exists
        MkDir dFolderPath
    On Error GoTo ClearError
    
    ' Append a time stamp to the file base name
    ' Don't forget the trailing dot in the timestamp.
    ' If the file name has other dots, it will replace them, too. Improve!
    Dim dFileName As String:
    dFileName = Replace(wb.Name, ".", Format(Now, "ddmmyyyy_hhmmss AM/PM."))
    
    ' Build the destination file path.
    Dim dFilePath As String:
    dFilePath = dFolderPath & Application.PathSeparator & dFileName
    
    ' Save a copy.
    wb.SaveCopyAs Filename:=dFilePath
    
    ' Inform.
    If ShowMessages Then
        MsgBox "Created a backup of the workbook at """ & dFilePath & """.", _
            vbInformation, PROC_TITLE
    End If
    
ProcExit:
    Exit Sub
ClearError:
    ' An unexpected error occured.
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub

Upvotes: 0

Related Questions