web-dev-qa-db-ja.com

新しいExcelドキュメントをプロンプトのないマクロなしのワークブックとして保存する

Excel 2010を使用しています。このテンプレートを使用して新しいドキュメントが作成されると自動的に更新されるように設定されているテキストファイルへのデータ接続を持つExcelマクロ対応テンプレートがあります。

次のマクロは、「ThisWorkbook」オブジェクト内にあり、新しいドキュメントを保存する前にデータ接続を削除します。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    Do While ActiveWorkbook.Connections.Count > 0
        ActiveWorkbook.Connections.Item(ActiveWorkbook.Connections.Count).Delete
    Loop

End Sub

ユーザーが保存アイコンをクリックするか、Ctrl + Sを押してファイル名を入力し、[保存]をクリックしてマクロなしのExcelブックとして保存すると（デフォルトで必要なファイルタイプであるため）、次のメッセージが表示されます。

次の機能は、マクロなしのブックには保存できません。

•VBプロジェクト

これらの機能を含むファイルを保存するには、[いいえ]をクリックし、[ファイルの種類]ボックスの一覧でマクロが有効なファイルの種類を選択します。

マクロなしのブックとして保存を続けるには、[はい]をクリックします。

このメッセージが表示されないようにして、ユーザーがマクロなしのブックを続行したいとExcelに想定させることはできますか？

私はすべてを検索しましたが、ExcelにVBプロジェクトがこのメッセージを表示させないようにするために、自分自身を削除するワークブックオブジェクトにコードを追加できる可能性があることを理解していますが、これには各ユーザーが回避したいトラストセンター設定（VBAプロジェクトオブジェクトモデルへのトラストアクセス）を変更します。

私も使用の提案を見てきました：

Application.DisplayAlerts = False

しかし、これを機能させることはできません。その使用例はすべて、ドキュメントの保存も処理しているサブ内にあるようですが、私の状況では、BeforeSaveサブは、ドキュメントがデフォルトの非VBAの方法で保存される前に終了するため、おそらく機能しません。

このプロパティは、サブルーチンが終了した後/保存が実際に行われる前に、デフォルトのTrueにリセットされますか？

私が出してしまったかもしれないナンセンスについての謝罪、VBAでの私の経験は非常に限られています。

excelvbaexcel-vbaexcel-2010
15
Tom Turner

Excel 2010ではテストできませんが、少なくとも2016年は問題なく動作します。

Sub SaveAsRegularWorkbook()

    Dim wb As Workbook
    Dim Path As String

    Set wb = ThisWorkbook
    Path = "T:\he\Path\you\prefer\"
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    wb.SaveAs Filename:=Path & "Test.xlsx", FileFormat:=51
    Application.DisplayAlerts = True
    Application.EnableEvents = True

End Sub

試してみる。

3
EarlyBird2

別のアプローチ...テンプレートが読み込まれるときに、ユーザーに次の名前で保存するように要求します（同様の状況のワークブック/テンプレートがあります...）。これにより、ユーザーのドキュメントフォルダーまで開くことができますが、任意の場所に保存するように調整できます。

ThisWorkbookモジュールの中に、次のように配置します。

Option Explicit

Private Sub Workbook_Open()
    Dim loc As Variant
    Application.DisplayAlerts = False
    loc = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As...", InitialFileName:="%USERPROFILE%\Documents\NAME_OF_FILE")
    If loc <> False Then
        ActiveWorkbook.SaveAs Filename:=loc, FileFormat:=51
        Exit Sub
    End If
    Application.DisplayAlerts = True
End Sub

Edit1：ベーステンプレート名を使用してifステートメントを追加し、後続の保存で名前を付けて保存を要求しないようにします。

Option Explicit

Private Sub Workbook_Open()
    If ActiveWorkbook.Name = "_NAME_OF_FILE.xlsb" Then
        Dim loc As Variant
        Application.DisplayAlerts = False 
        loc = Application.GetSaveAsFilename(FileFilter:="Excel Files (*.xlsx), *.xlsx", Title:="Save As...", InitialFileName:="%USERPROFILE%\Documents\_NAME_OF_FILE")
        If loc <> False Then
            ActiveWorkbook.SaveAs Filename:=loc, FileFormat:=51
            Exit Sub
        End If
        Application.DisplayAlerts = True
    End If
End Sub
2
Cyril

この答えについては、Excelマクロ対応テンプレートとはxltmファイルを意味すると想定しています。また、「新しいドキュメント」とは、ユーザーがxtlmファイルをダブルクリックしたときに生成されるドキュメントであることを推測します（したがって、この新しいファイルはまだ保存されていないため、場所がありません）。

この問題を解決するには、カスタムSaveAsウィンドウ（Application.GetSaveAsFilename）を使用して、Workbook_BeforeSaveイベントマクロが呼び出されたときにユーザーがファイルを保存する方法をより詳細に制御します。

これを実装する方法は次のとおりです。

1-このコードを新しいモジュールにコピーします。

Option Explicit  

Sub SaveAsCustomWindow()  

    Const C_PROC_NAME As String = "SaveAsCustomWindow"
    Dim strFullFileName As String, strPreferedFolder As String, strDefaultName As String
    Dim UserInput1 As Variant, UserInput2 As Variant
    Dim isValidName As Boolean, isFileClosed As Boolean, isWorkbookClosed As Boolean
    Dim strFilename As String, strFilePath As String


    'To avoid Warning when overwriting
    Application.DisplayAlerts = False
    'Disable events (mostly for the BeforeSave event) to avoid creating infinite loop
    Application.EnableEvents = False
    On Error GoTo ErrHandler

    'Customizable section
    strDefaultName = ThisWorkbook.Name
    strPreferedFolder = Environ("USERPROFILE")

    Do While isWorkbookClosed = False
        Do While isFileClosed = False
            Do While isValidName = False
                UserInput1 = Application.GetSaveAsFilename(InitialFileName:=strPreferedFolder & "\" & strDefaultName, FileFilter:="Excel Workbook (*.xlsx),*.xlsx")

                If UserInput1 = False Then
                    GoTo ClosingStatements 'This is important to take care of the case when the user presses cancel
                Else
                    strFullFileName = UserInput1
                End If

                strFilename = Right(strFullFileName, Len(strFullFileName) - InStrRev(strFullFileName, "\"))
                strDefaultName = strFilename

                strFilePath = Left(strFullFileName, InStrRev(strFullFileName, "\") - 1)
                strPreferedFolder = strFilePath

                'If the file exist, ask for overwrite permission
                If Dir(strFullFileName) <> "" Then
                    UserInput2 = MsgBox(strFilename & " already exists." & vbNewLine & "Do you want to overwrite?", vbYesNoCancel Or vbExclamation)
                    If UserInput2 = vbNo Then
                        isValidName = False
                    ElseIf UserInput2 = vbYes Then
                        isValidName = True
                    ElseIf UserInput2 = vbCancel Then
                        GoTo ClosingStatements
                    Else
                        GoTo ClosingStatements
                    End If
                Else
                    isValidName = True
                End If
            Loop

            'Check if file is actually open
            If isFileOpen(strFullFileName) Then
                MsgBox "The workbook you want to overwrite is currently open. Choose a different name, or close the  workbook before saving.", vbExclamation
                isValidName = False
                isFileClosed = False
            Else
                isFileClosed = True
            End If
        Loop

        'Check if an opened workbook has the same name
        If isWorkbookOpen(strFilename) Then
            MsgBox "You cannot save this workbook with the same name as another open workbook or add-in. Choose a different name, or close the other workbook or add-in before saving.", vbExclamation
            isValidName = False
            isFileClosed = False
            isWorkbookClosed = False
        Else
            isWorkbookClosed = True
        End If
    Loop

    ThisWorkbook.SaveAs Filename:=strFullFileName, FileFormat:=xlOpenXMLWorkbook

ClosingStatements:
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Exit Sub
ErrHandler:
    Call MsgBox("Run-time error '" & Err.Number & "': " & Err.Description & vbNewLine & _
         "While running: " & C_PROC_NAME & IIf(Erl <> 0, vbNewLine & "Error Line: " & Erl, "")
    GoTo ClosingStatements

End Sub

Function isFileOpen(ByVal Filename As String) As Boolean

    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open Filename For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
        Case 0:    isFileOpen = False
        Case 70:   isFileOpen = True
    End Select

End Function

Function isWorkbookOpen(ByVal Filename As String) As Boolean

    Dim wb As Workbook, ErrNo As Long

    On Error Resume Next
    Set wb = Workbooks(Filename)
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
        Case 0:         isWorkbookOpen = True
        Case Else:      isWorkbookOpen = False
    End Select

End Function

パート1の説明：これは少しやり過ぎに見えるかもしれませんが、潜在的なエラーを考慮し、Application.EnableEventsの設定が元に戻されていることを確認するには、すべてのエラー処理が重要です。エラーが発生した場合でもTRUEに。そうしないと、Excelアプリケーションですべてのイベントマクロが無効になります。

2-Workbook_BeforeSaveイベントプロシージャ内でSaveAsCustomWindowプロシージャを次のように呼び出します。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)

    'Your code

    If ThisWorkbook.Path = "" Then
        SaveAsCustomWindow
        Cancel = True
    End If

End Sub

デフォルトのSaveAsウィンドウが表示されないようにするには、変数Cancel = Trueを設定する必要があることに注意してください。また、ifステートメントは、ファイルにneverが保存されている場合にのみカスタムSaveAsウィンドウが使用されるようにするためにあります。

1
DecimalTurn

あなたの質問に答えるには：

このメッセージが表示されないようにすることは可能ですか？

はい、Application.DisplayAlertsプロパティ

Excelで、ユーザーがマクロなしのワークブックの続行を望んでいると想定することはできますか？

いいえ、ワークブックを保存してSaveAs Excelイベントをバイパスし、ユーザー入力（Path＆Filename）を使用して必要な形式でワークブックを保存する手順を記述する必要があります。

次の手順では、FileDialogを使用してユーザーからパスとファイル名を取得し、警告メッセージを表示せずにファイルを保存します。それでも説明コメントをいくつか追加しました。質問がある場合はお知らせください。

これらの手順をThisWorkbookモジュールにコピーします。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Cancel = True       'Prevents repetitive Save
    Call Workbook_BeforeSave_ApplySettings_And_Save
    End Sub


Private Sub Workbook_BeforeSave_ApplySettings_And_Save()
Dim fd As FileDialog, sFilename As String

    Rem Sets FileDialog to capture user input
    Set fd = Application.FileDialog(msoFileDialogSaveAs)
    With fd
        .InitialView = msoFileDialogViewDetails
        .Title = vbNullString               'Resets default value in case it was changed
        .ButtonName = vbNullString          'Resets default value in case it was changed
        .AllowMultiSelect = False
        If .Show = 0 Then Exit Sub          'User pressed the Cancel Button
        sFilename = .SelectedItems(1)
    End With

    With ThisWorkbook

        Do While .Connections.Count > 0
            .Connections.Item(.Connections.Count).Delete
        Loop

        Application.EnableEvents = False                                'Prevents repetition of the Workbook_BeforeSave event
        Application.DisplayAlerts = False                               'Prevents Display of the warning message
        On Error Resume Next                                            'Prevents Events and Display staying disable in case of error
        .SaveAs Filename:=sFilename, FileFormat:=xlOpenXMLWorkbook      'Saves Template as standard Excel using user input
        If Err.Number <> 0 Then
            MsgBox "Run-time error " & Err.Number & String(2, vbLf) _
                & Err.Description & String(2, vbLf) _
                & vbTab & "Process will be cancelled.", _
                vbOKOnly, "Microsoft Visual Basic"
        End If
        On Error GoTo 0
        Application.DisplayAlerts = True
        Application.EnableEvents = True

    End With

    End Sub
0
EEM