Aktualisieren Sie den Dateinamen auf Workbook_BeforeSave

Question

Ich versuche, Excel speichern eine Datei mit einem eindeutigen Namen, wenn es gespeichert wird. Diese
wird meist in Excel 2003 verwendet werden, sondern muss auch arbeiten 2010

Die Idee ist, dass der Benutzer eine Vorlagendatei öffnet, und wenn sie klicken Sie auf ‚Speichern‘ oder schließen Sie einfach die Arbeitsmappe als template_1 retten wird, template_2 usw.

Das funktioniert gut, wenn sie auf "Speichern" klicken, aber wenn sie die Datei schließen, fragt sie, ob Sie Änderungen an der ursprünglichen Datei speichern, unter dem neuen Namen speichern und danach fragen möchten Benutzer möchte Änderungen speichern ... und speichert dann und fragt, ob der Benutzer Änderungen speichern möchte, und so weiter. Offensichtlich will ich nur, dass es einmal speichert und dann schließt - aber das tut es nicht.

Ich habe versucht, die Saved Eigenschaft auf TRUE zu setzen. Ich habe versucht, Cancel = True nach dem Speichern, aber dies verursacht Excel mit einem Absturz zu crashen Excel hat ein Problem festgestellt und muss wirklich Ihren Tag Nachricht schreiben.

Im folgenden Code habe ich versucht, das Entfernen der Saved=TRUE und die Cancel=TRUE, ich habe versucht, sie um zu bewegen - Abbrechen vor dem Speichern, Abbrechen nach dem Speichern, aber innerhalb des If...End If Block, vor und nach dem 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 

der GenerateUniqueName Code ist unten - das den Dateinamen übernimmt keine Unterstrich enthalten und fügt die Nummer an den Dateinamen als _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 

Answer 1

Bitte versuchen Sie dies und sehen Sie, ob Ihre Probleme gelöst sind? Ich habe Ihre Funktion nicht unten aufgeführt, da diese unverändert bleibt.

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 

Answer 2

Ich habe meinen BeforeSave Code leicht aktualisiert - ich bin immer noch nicht sicher, ob ThisWorkbook.Saved = True : Cancel = True richtig ist, aber ich weiß, es stürzt ab, wenn ich nicht in den Cancel = True setzen Sie:

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

    On Error GoTo ERROR_HANDLER 

    ThisWorkbook.Saved = True 
    Cancel = True 

    NewFileName = GenerateUniqueName(ThisWorkbook.FullName) 
    If NewFileName <> "" Then 
     Application.EnableEvents = False 
     ThisWorkbook.SaveAs NewFileName, ThisWorkbook.FileFormat 
     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 

mit Diesem Speichern Sie die Datei ein neuer Name, aber nicht schließen.

Wie Absinthe und Mr.Burns sagten - schauen Sie auf das nahe Ereignis.
Dies zeigt an, ob die Arbeitsmappe gespeichert wurde. Wenn dies nicht der Fall ist, wird das Schließen-Ereignis abgebrochen, die Arbeitsmappe wird gespeichert und dann wird sie geschlossen, andernfalls wird sie ohne Speichern geschlossen.

Private Sub Workbook_BeforeClose(Cancel As Boolean) 

    Dim NewFileName As String 

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

End Sub 

Kann jemand hier irgendwelche Fallstricke finden?
Bearbeiten: Ich habe eine Fallstricke gefunden - Sie können Save As nicht verwenden.