更新Workbook_BeforeSave上的文件名 [英] Update the file name on Workbook_BeforeSave
问题描述
我试图让Excel在保存文件时保存唯一的名称。
这主要是在Excel 2003中使用，但也必须在2010年使用。
想法是用户打开一个模板文件，如果他们点击保存或只是关闭工作簿，它将另存为template_1，template_2等。
如果点击保存，则可以正常工作，但是如果关闭文件，则会询问您是否要保存原始文件上的更改，并将其保存在新名称下，然后询问是否用户希望保存更改...然后保存并询问用户是否要保存更改，等等。显然，我只希望它保存一次然后关闭，但不会。 / p>
我已经尝试将保存的属性设置为TRUE。我已经尝试了取消= True 保存后，这会导致Excel崩溃与 Excel遇到问题，真的需要拧紧你的一天键入消息。
在下面的代码中，我尝试删除 Saved = TRUE 和 Cancel = TRUE ，我已经尝试移动它们 - 在保存之前取消，保存后取消，但在内如果... End If 块， EnableEvents 代码之前和之后：
私人Sub Workbook_BeforeSave（ByVal SaveAsUI As Boolean，Cancel As Boolean）
Dim NewFileName As String
错误GoTo ERROR_HANDLER
NewFileName = GenerateUniqueName（ThisWorkbook.FullName）
如果NewFileName<> 然后
Application.EnableEvents = False
ThisWorkbook.SaveAs NewFileName，ThisWorkbook.FileFormat
ThisWorkbook.Saved = True
Application.EnableEvents = True
End If
FastExit：
取消= True
错误GoTo 0
退出Sub
ERROR_HANDLER：
MsgBoxError&错误编号& vbCr& _
（& Err.Description&）在程序ThisWorkbook.Workbook_BeforeSave。 &安培; vbCr& vbCr& _
DOCUMENT NOT SAVED。，vbCritical + vbOKOnly
Application.EnableEvents = True
简历FastExit
End Sub
以下代码为$ code GenerateUniqueName - 这假定文件名不包含下划线字符并将该号码附加到文件名为_1，_2等：
'---------- -------------------------------------------------- ----------
'GenerateUniqueName
'
'生成一个不存在的文件名，在文件名和文件名之间附加一个数字
'延期。
'示例：GenerateUniqueName（c：\folder\file.ext）=c：\folder\file_4.ext
'---------- -------------------------------------------------- ----------
函数GenerateUniqueName（FullFileName As String，可选fAlwaysAddNumber As Boolean）As String
Dim oFSO As Object
设置oFSO = CreateObject（ Scripting.FileSystemObject）
如果不是oFSO.FileExists（FullFileName）而不是fAlwaysAddNumber然后
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）
如果strExt<> 然后
strBaseName = oFSO.GetBaseName（FullFileName）
如果InStrRev（strBaseName，_）> 0然后
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& _&我& &安培; strExt
循环while oFSO.FileExists（strNewName）
GenerateUniqueName = strNewName
Else
MsgBox文件名必须包含文件扩展名。 &安培; vbCr& _
eg .xls或.xlsx，vbCritical + vbOKOnly
GenerateUniqueName =
End If
End If
Set oFSO = Nothing
结束功能
请尝试这看看你的问题是否解决了？我没有包含你的功能，因为它保持不变。
Option Explicit
Private Sub Workbook_BeforeClose Cancel As Boolean）
Dim Ret As Variant
如果ThisWorkbook.Saved = False然后
ThisWorkbook.Saved = True
Ret = MsgBox（would你喜欢保存这个工作簿？，vbYesNo）
如果Ret = vbYes Then SaveWithUniqueName
End If
End Sub
Private Sub Workbook_BeforeSave（ByVal SaveAsUI As Boolean，Cancel As Boolean）
如果ThisWorkbook.Saved = True然后退出Sub
如果SaveAsUI = True则退出Sub'~~>检查Save As
取消= True
SaveWithUniqueName
End Sub
Sub SaveWithUniqueName（）
Dim NewFileName As String
错误GoTo ERROR_HANDLER
NewFileName = GenerateUniqueName（ThisWorkbook.FullName）
如果NewFileName<> 然后
Application.EnableEvents = False
ThisWorkbook.SaveAs NewFileName，ThisWorkbook.FileFormat
ThisWorkbook.Saved = True
Application.EnableEvents = True
End If
FastExit：
错误GoTo 0
退出Sub
ERROR_HANDLER：
MsgBoxError&错误编号& vbCr& _
（& Err.Description&）在程序ThisWorkbook.Workbook_BeforeSave。 &安培; vbCr& vbCr& _
DOCUMENT NOT SAVED。，vbCritical + vbOKOnly
Application.EnableEvents = True
简历FastExit
End Sub
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
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
这篇关于更新Workbook_BeforeSave上的文件名的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
