Workbook_BeforeSaveのファイル名を更新します。

Question

保存するたびに、Excelにファイルを一意の名前で保存しようとしています。
これは主にExcel 2003で使用されますが、2010年にも使用されます。

ユーザーはテンプレートファイルを開き、[保存] template_2など

彼らは「保存」をクリックする場合、これは正常に動作しますが、彼らは、ファイルを閉じた場合、それはあなたが元のファイルに変更を保存したい場合は、新しい名前で保存します聞いてきますし、その後どうか尋ねますユーザーは変更を保存する必要があります...ユーザーが変更を保存するかどうかなどを保存して尋ねます。明らかに、私はそれを一度保存​​して閉じてしまうだけですが、そうではありません。

SavedプロパティをTRUEに設定しようとしました。保存後にCancel = Trueを試しましたが、Excelがクラッシュする原因となります。Excelに問題が発生しました。タイプのメッセージが表示されます。コードで

私はSaved=TRUEとCancel=TRUEを削除しようとしたの下に、私は周りにそれらを移動しようとした - 、保存する前にキャンセル保存した後にキャンセルが、If...End Ifブロック内で、EnableEventsコードの前と後：

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 

GenerateUniqueNameコードは以下の通りです - これは、アンダースコア文字を含まないファイル名を想定し、など_1、_2、などのファイル名に番号が追加されます。

'---------------------------------------------------------------------- 
' 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

これを試して問題が解決したかどうか確認してください。私は変更されていないので、以下のあなたの関数を含めていない。

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

私は少し私のBeforeSaveコードを更新しました - 私はまだThisWorkbook.Saved = True : Cancel = Trueが正しいかどうかわからないんだけど、私はCancel = Trueに入れていない場合、それがクラッシュ知っていますか：

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 

これは、使用してファイルを保存します新しい名前ですが、閉じないでください。

AbsintheとMr.Burnsが言ったように - 近いイベントを見てください。
これは、ブックが保存されているかどうかを調べます。閉じイベントがキャンセルされていない場合は、ブックが保存されて閉じられます。保存されていなければ、保存せずに終了します。

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 

誰でもここに落とし穴を見つけることができますか？
編集：私は1つの落とし穴を見つけました。あなたはSave Asを使用できません。