Workbook_BeforeSave删除了“另存为对话”中的文件类型

Question

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

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

但是，当用户进行“另存为”时，对话框将不提供任何文件类型选项，如果在保存过程中没有指定，它将创建一个缺少扩展名的文件。

如何调整此代码以防止“另存为”对话框删除文件类型选项？出于好奇它为什么要这么做？

解出

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

缺少默认文件类型是由Application.GetSaveAsFilename()造成的。

尝试使用Application.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