我编写了代码来在关闭用户窗体时保存备份。
当工作簿可见或单击“保存”按钮时它可以工作。
工作簿_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
保存_备份代码
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
当我检查备份文件夹时,没有文件。
但是关闭用户窗体并且应用程序可见后,当我保存工作簿时,备份完成,我可以在备份文件夹中看到文件。
工作簿模块(
ThisWorkbook
)
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
CreateWorkbookBackup Me, True
End Sub
标准模块,例如
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