My code in BeforeSave is preventing the save???

[Clif McIrvin]

I added code to my personal macro workbook to save a copy before saving changes.
The code is working as intended, but I have discovered that the new changes are not getting saved.
That is, I'm getting a timestamped copy of the original workbook, but the new changes are not getting saved.
I'm hoping someone can point out what my problem is.
My first thought was that the file system object .CopyFile method was changing the Cancel value, but setting Cancel=False before exit did not solve the problem.
Here is my code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
   
   With Application
      .ScreenUpdating = True
      .DisplayStatusBar = True
      .StatusBar = "Saving " & ThisWorkbook.Name & "..."
   End With

' create copy of thisworkbook with timestamp
' S:\QC\Excel\XLSTART --} S:\QC\Excel
   v = Copy_File(ThisWorkbook.FullName, _
      Replace(ThisWorkbook.FullName, "\XLSTART", "", Count:=1) _
      & Format(Now, "yyyy-mm-dd_hh-nn-ss"))

   If v <> True Then
      MsgBox "Error " & v & Error(v) & vbCrLf & _
         "Unable to copy " & ThisWorkbook.FullName, vbCritical + vbOKOnly, _
         "VBA Code Backup Error"
   End If
   
   Application.StatusBar = False 'return control to Excel
   Cancel = False
   
End Sub

And the file system object call:

Public Function Copy_File(srcFilePath As String, _
         destFilePath As String, _
         Optional overwrite As Boolean = False) As Variant
         
    If fso Is Nothing Then ' fso is a global variable
        Set fso = GetFileSystemObject()
    End If
    
    Err.Clear
    On Error Resume Next
    fso.CopyFile srcFilePath, destFilePath, overwrite
    Copy_File = Err.Number
    On Error GoTo 0
    If Copy_File = 0 Then
      Copy_File = True
    End If
    
End Function

I'm running Microsoft® Excel® for Microsoft 365 MSO (Version 2312 Build 16.0.17126.20190) 64-bit

 

[rlv01]

Something to try.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim CopyResult As Variant, OverWrite As Boolean
    Dim destFilePath As String
    
    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .StatusBar = "Saving " & ThisWorkbook.Name & "..."
    End With
    
    ' create copy of thisworkbook with timestamp
    ' S:\QC\Excel\XLSTART --} S:\QC\Excel
    
    OverWrite = True
    destFilePath = Replace(ThisWorkbook.FullName, "\XLSTART", "", count:=1) & Format(Now, "yyyy-mm-dd_hh-nn-ss")
    CopyResult = Copy_File(ThisWorkbook.FullName, destFilePath, OverWrite)
    
    If CopyResult <> True Then
        MsgBox "Error " & CopyResult & ",'" & Error(CopyResult) & "'" & vbCrLf & "Unable to copy " & ThisWorkbook.FullName, vbCritical + vbOKOnly, "VBA Code Backup Error"
    End If
    
    Application.StatusBar = False 'return control to Excel
End Sub

Public Function Copy_File(srcFilePath As String, _
    destFilePath As String, _
    Optional OverWrite As Boolean) As Variant
    
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    On Error GoTo CopyError
    fso.CopyFile srcFilePath, destFilePath, OverWrite
    DoEvents
    Copy_File = True
    Exit Function

CopyError:
    Copy_File = Err.Number
End Function

 

[Clif McIrvin]

Something to try.

Thank you for cleaning up my code -- much better at self documenting now!
Unfortunately, the functional changes you suggested did not change the results.

But: you did prime the pump, and with some more testing I now have code that does what I wanted. That is, when I Save my personal macro workbook I get a copy of the file on disk (before any of this session's edits) AND the current session in memory is also saved.

I added this:

    Application.EnableEvents = False
    ThisWorkbook.Save
    DoEvents
    Application.EnableEvents = True

So now I have:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim CopyResult As Variant, OverWrite As Boolean
    Dim destFilePath As String
    
    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .StatusBar = "Saving " & ThisWorkbook.Name & "..."
    End With
    
    ' create copy of thisworkbook with timestamp
    ' S:\QC\Excel\XLSTART --} S:\QC\Excel
    
    OverWrite = True
    destFilePath = Replace(ThisWorkbook.FullName, "\XLSTART", "", Count:=1) & Format(Now, "yyyy-mm-dd_hh-nn-ss")
    CopyResult = Copy_File(ThisWorkbook.FullName, destFilePath, OverWrite)
    
    ' and save current session to disk
    Application.EnableEvents = False
    ThisWorkbook.Save
    DoEvents
    Application.EnableEvents = True
    
    If CopyResult <> True Then
        MsgBox "Error " & CopyResult & ",'" & Error(CopyResult) & "'" & vbCrLf & "Unable to copy " & ThisWorkbook.FullName, vbCritical + vbOKOnly, "VBA Code Backup Error"
    End If
    
    Application.StatusBar = False 'return control to Excel
End Sub

And Copy_File (in a code module) with the supporting routine I forgot to include the first time:

Option Explicit

Global fso As Object

Public Function GetFileSystemObject( _
        Optional ReleaseIt As Boolean = False _
        ) As Object
    
    Select Case True 'lazy evaluation
        Case ReleaseIt
            Set fso = Nothing
        Case fso Is Nothing
            Set fso = CreateObject("Scripting.FileSystemObject")
    End Select
    
    Set GetFileSystemObject = fso
    
End Function

Public Function Copy_File(srcFilePath As String, _
         destFilePath As String, _
         Optional OverWrite As Boolean = False) As Variant
         
    If fso Is Nothing Then
        Set fso = GetFileSystemObject()
    End If
    
    On Error GoTo CopyError
    fso.CopyFile srcFilePath, destFilePath, OverWrite
    DoEvents
    Copy_File = True
    Exit Function

CopyError:
    Copy_File = Err.Number
    
End Function

Looking at this code today I see that I have redundant Set fso = GetFileSystemObject() instructions because of the way I coded GetFileSystemObject(). This change should fix that:

    If fso Is Nothing Then
        GetFileSystemObject()
    End If

My File System Object routines were coded with other tasks in mind, particularly cases where the code is iterating through a folder tree, so the code was written to keep the FileSystemObject alive once it was instantiated.

Again, Thank You!

 

[rlv01]

Looks a bit complex, but if it works for you then all is good . Not sure why you are making fso a global variable and then writing a separate routine to clear it. It would be fine to just declare fso a local variable in Sub Copy_File. In fact, you don't even need to explicitly declare an fso object variable:

Public Function Copy_File(srcFilePath As String, _
    destFilePath As String, _
    Optional OverWrite As Boolean = False) As Variant
   
    On Error GoTo CopyError
    With CreateObject("Scripting.FileSystemObject")
        .CopyFile srcFilePath, destFilePath, OverWrite
    End With
   
    DoEvents
    Copy_File = True
    Exit Function
   
CopyError:
    Copy_File = Err.Number
End Function

 

[Clif McIrvin]

Definitely overkill for this case.
But, since my FileSystem module was available, I used it.
When using Dir() to ransack a file server folder tree (30,000+ files) and build a worksheet with file names and access times, etc it seemed a good idea to only instantiate the FileSystemObject once. At the end of the process there was a final call to release the object.
Why Dir() and not the FileSystemObject itself? At the time a) I was far more familiar with Dir() from my old GWBASIC days and b) somewhere I came up with the impression that Dir() was much faster. I added the FileSystemObject when I realized that it could cough up information that I didn't know how to get otherwise. (Certainly faster than opening each workbook to read properties!)

 

[Clif McIrvin]

For future readers: Everything seemed to be performing as expected, except that I began to experience personal macro workbook corruption
Removing this bit of code

 ' and save current session to disk
    Application.EnableEvents = False
    ThisWorkbook.Save
    DoEvents
    Application.EnableEvents = True

seems to have resolved that issue.

YMMV