Update the file name on Workbook_BeforeSave

Question

I'm trying to have Excel save a file with a unique name whenever it's saved.
This will mostly be used within Excel 2003, but must also work on 2010.

The idea is that the user opens a template file and if they click 'Save' or just close the workbook it will save as template_1, template_2, etc.

This works fine if they click 'Save', but if they close the file it will ask if you want to save changes on the original file, saves it under the new name and then ask if the user wants to save changes... and then saves and asks if the user wants to save changes, and so on. Obviously, I only want it to save the once and then close - but it doesn't.

I've tried setting the Saved property to TRUE. I've tried Cancel = True after the save but this causes Excel to crash with a Excel has encountered a problem and really needs to screw your day up type message.

In the code below I've tried removing the Saved=TRUE and the Cancel=TRUE, I've tried moving them around - Cancel before the Save, Cancel after the Save but within the If...End If block, before and after the EnableEvents code:

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim NewFileName As String

    On Error GoTo ERROR_HANDLER

    NewFileName = GenerateUniqueName(ThisWorkbook.FullName)
    If NewFileName <> "" Then
        Application.EnableEvents = False
        ThisWorkbook.SaveAs NewFileName, ThisWorkbook.FileFormat
        ThisWorkbook.Saved = True
        Application.EnableEvents = True
    End If

FastExit:

    Cancel = True

    On Error GoTo 0
    Exit Sub

ERROR_HANDLER:
    MsgBox "Error " & Err.Number & vbCr & _
        " (" & Err.Description & ") in procedure ThisWorkbook.Workbook_BeforeSave." & vbCr & vbCr & _
        "DOCUMENT NOT SAVED.", vbCritical + vbOKOnly
    Application.EnableEvents = True
    Resume FastExit

End Sub

The GenerateUniqueName code is below - this assumes the file name doesn't contain an underscore character and appends the number to the file name as _1, _2, etc:

'----------------------------------------------------------------------
' GenerateUniqueName
'
'   Generates a file name that doesn't exist by appending a number
'   inbetween the base name and the extension.
'   Example: GenerateUniqueName("c:\folder\file.ext") = "c:\folder\file_4.ext"
'----------------------------------------------------------------------
Function GenerateUniqueName(FullFileName As String, Optional fAlwaysAddNumber As Boolean) As String

    Dim oFSO As Object
    Set oFSO = CreateObject("Scripting.FileSystemObject")

    If Not oFSO.FileExists(FullFileName) And Not fAlwaysAddNumber Then
        GenerateUniqueName = FullFileName
    Else
        Dim strExt As String
        Dim strNonExt As String
        Dim strBaseName As String
        Dim strNewName As String
        Dim i As Integer
        strExt = oFSO.GetExtensionName(FullFileName)
        If strExt <> "" Then
            strBaseName = oFSO.GetBaseName(FullFileName)
            If InStrRev(strBaseName, "_") > 0 Then
                i = Val(Mid(strBaseName, InStrRev(strBaseName, "_") + 1, Len(strBaseName)))
                strBaseName = Left(strBaseName, InStrRev(strBaseName, "_") - 1)
            End If
            strNonExt = oFSO.buildpath(oFSO.GetParentFolderName(FullFileName), strBaseName)
            Do
                i = i + 1
                strNewName = strNonExt & "_" & i & "." & strExt
            Loop While oFSO.FileExists(strNewName)
            GenerateUniqueName = strNewName
        Else
            MsgBox "File name must contain a file extension." & vbCr & _
                "e.g. .xls or .xlsx", vbCritical + vbOKOnly
            GenerateUniqueName = ""
        End If
    End If

    Set oFSO = Nothing

End Function

Siddharth Rout · Accepted Answer

Please try this and see if your problems are solved? I have not included your function below as that remains unchanged.

Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim Ret As Variant

    If ThisWorkbook.Saved = False Then
        ThisWorkbook.Saved = True

        Ret = MsgBox("Would you like to save this workbook?", vbYesNo)

        If Ret = vbYes Then SaveWithUniqueName
    End If
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    If ThisWorkbook.Saved = True Then Exit Sub

    If SaveAsUI = True Then Exit Sub '~~> Checks for Save As

    Cancel = True
    SaveWithUniqueName
End Sub

Sub SaveWithUniqueName()
    Dim NewFileName As String

    On Error GoTo ERROR_HANDLER

        NewFileName = GenerateUniqueName(ThisWorkbook.FullName)

    If NewFileName <> "" Then
        Application.EnableEvents = False
        ThisWorkbook.SaveAs NewFileName, ThisWorkbook.FileFormat
        ThisWorkbook.Saved = True
        Application.EnableEvents = True
    End If

FastExit:
    On Error GoTo 0
    Exit Sub

ERROR_HANDLER:
    MsgBox "Error " & Err.Number & vbCr & _
        " (" & Err.Description & ") in procedure ThisWorkbook.Workbook_BeforeSave." & vbCr & vbCr & _
        "DOCUMENT NOT SAVED.", vbCritical + vbOKOnly
    Application.EnableEvents = True
    Resume FastExit
End Sub

Update the file name on Workbook_BeforeSave

Answers (2)

Related Questions