Workbook_BeforeSave另存为对话框中删除文件types

我有一个由多个用户访问的主文件，每月用作模板。 我使用下面的代码来允许某人另存为 ，但不保存在模板上。 如果在文件名中没有find“模板”，我也使它无法运行，以便保存的副本可以根据需要重新打开和编辑。 这是代码：

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim strOrigFile As String strOrigFile = ActiveWorkbook.FullName Dim strNamePath As String Dim strWorkOrNot As Integer strWorkOrNot = InStr(1, strOrigFile, "Template") If strWorkOrNot = 0 Then GoTo AbortProcess If SaveAsUI Then Cancel = True strNamePath = Application.GetSaveAsFilename Select Case strNamePath Case "False" Case strOrigFile MsgBox "It may be a bad idea to save over the template. You should use Save-As and create a new file.", vbCritical, "Avoid Corrupting the Template!" Case Else Application.EnableEvents = 0 Me.SaveAs strNamePath Application.EnableEvents = 1 End Select Else If ThisWorkbook.Path & "\" & ThisWorkbook.Name = strOrigFile Then Cancel = True MsgBox "It may be a bad idea to save over the template. You should use Save-As and create a new file.", vbCritical, "Avoid Corrupting the Template!" End If End If AbortProcess: End Sub 

但是，当用户执行另存为时，对话框不会提供任何文件types选项，如果有人在保存期间未指定，则会创build缺less扩展名的文件。

如何调整此代码以使“另存为”对话框消除文件types选项？ 出于好奇，为什么这样做呢？

[解决了]

 Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim strOrigFile As String strOrigFile = ActiveWorkbook.FullName Dim strNamePath As String Dim strWorkOrNot As Integer strWorkOrNot = InStr(1, strOrigFile, "Template") If strWorkOrNot = 0 Then GoTo AbortProcess On Error GoTo SaveAsMacroWarning If SaveAsUI Then Cancel = True With Application.FileDialog(msoFileDialogSaveAs) .AllowMultiSelect = False .InitialFileName = "New" .Show If "False" Then Cancel = True Exit Sub Else strNamePath = .SelectedItems(1) End If End With Select Case strNamePath Case strOrigFile MsgBox "It may be a bad idea to save over the template. You should use Save-As and create a new file.", vbCritical, "Avoid Corrupting the Template!" Case Else Application.EnableEvents = 0 Me.SaveAs Filename:=strNamePath, FileFormat:=xlOpenXMLWorkbookMacroEnabled Application.EnableEvents = 1 End Select Else If ThisWorkbook.Path & "\" & ThisWorkbook.Name = strOrigFile Then Cancel = True MsgBox "It may be a bad idea to save over the template. You should use Save-As and create a new file.", vbCritical, "Avoid Corrupting the Template!" End If End If SaveAsMacroWarning: MsgBox "You'll need to save it as a Macro-Enabled file type.", vbCritical, "Save as Macro-Enabled" AbortProcess: End Sub 

Answer 1

缺less默认文件types是由Application引起的。 GetSaveAsFilename （）

尝试使用应用程序 FileDialog（msoFileDialogSaveAs） ：

 Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim fId As String, oldName As String, iniName As String, fn As String If SaveAsUI Then Cancel = True fId = " - " & Format(Now, "yyyy-mm-dd hh-mm-ss") oldName = ActiveWorkbook.Name oldName = Left(oldName, InStrRev(oldName, ".") - 1) iniName = Replace(ActiveWorkbook.FullName, oldName, oldName & fId) With Application.FileDialog(msoFileDialogSaveAs) .AllowMultiSelect = False .InitialFileName = iniName .Show If .SelectedItems.Count = 1 Then fn = .SelectedItems(1) fn = Right(fn, Len(fn) - InStrRev(fn, "\")) fn = Left(fn, InStrRev(fn, ".") - 1) If fn = oldName Then fn = Replace(.SelectedItems(1), fn, fn & fId) Application.EnableEvents = False Application.DisplayAlerts = False Me.SaveAs fn Application.DisplayAlerts = True Application.EnableEvents = True End If End With End If End Sub