'ファイルを開きモジュールをチェックするマクロ

'MakeDialogSheetマクロを実行してダイアログシートを作成し、
'Open_CheckModuleマクロを実行してください


Option Explicit

Private Const myTitle As String _
    = "ファイルを開きモジュールをチェック"
Private iDialogResult As Integer


Sub Open_CheckModule()
    Dim sMsgOpen As String
    Dim sFileFilter As String
    Dim oApp As Object
    Dim oDialogSheet As Object
    Dim oListBox As Object
    Dim oCheckBox As Object
    Dim oBook As Workbook
    Dim oSheet As Object
    Dim oName As Object
    Dim vFileNames As Variant
    Dim vFileName As Variant
    Dim iRet As Long
    Dim s As String

    On Error GoTo ErrorHandler

    Set oApp = Application

    sMsgOpen = "通常のダイアログボックスからファイルを開きますか?" & _
        Chr$(10) & "この方法でExcelファイルを開いた場合は、" & _
        "マクロウィルスに感染する危険性があります。"

    sFileFilter = StrConv( _
        "すべてのファイル (*.*),*.*," & _
        "Microsoft Excel ファイル (*.x*),*.x*," & _
        "テキスト ファイル (*.prn;*.txt;*.csv),*.prn;*.txt;*.csv," & _
        "Lotus 1-2-3 ファイル(*.w*),*.wk*," & _
        "QuattroPro/DOS ファイル (*.wq*),*.wq*," & _
        "Microsoft Works ファイル (*.wks),*.wks," & _
        "dBase ファイル (*.dbf),*.dbf", vbNarrow)

    Set oDialogSheet = ThisWorkbook.DialogSheets(1)
    Set oListBox = oDialogSheet.ListBoxes(1)
    Set oCheckBox = oDialogSheet.CheckBoxes(1)
    oCheckBox.Value = xlOff

    'ファイル名の入力
    vFileNames = Application.GetOpenFilename( _
        fileFilter:=sFileFilter, _
        filterIndex:=2, MultiSelect:=True)
    If VarType(vFileNames) = vbBoolean Then
        Exit Sub
    End If

    Application.Calculation = xlManual

    For Each vFileName In vFileNames

        If Not (UCase(Right$(vFileName, 4)) Like ".X??") Then
            iRet = MsgBox(sMsgOpen & Chr$(10) & Chr$(10) & _
                vFileName, vbYesNoCancel Or vbExclamation, myTitle)
            Select Case iRet
                Case vbYes
                    On Error Resume Next
                    Application.Dialogs(xlDialogOpen).Show vFileName
                    On Error GoTo ErrorHandler
                    GoTo Continue
                Case vbCancel
                    GoTo Continue
            End Select
        End If

        Set oBook = Workbooks.Open(vFileName)

        oListBox.RemoveAllItems

        For Each oName In oBook.Names
            s = UCase(oName.Name)
            If (s Like "AUTO_*") Or (s Like "*!AUTO_*") Then
                oListBox.AddItem "[名前] " & oName.Name
            End If
        Next
        For Each oSheet In oBook.Modules
            If oSheet.Visible = -1 Then
                oListBox.AddItem "[表示] " & oSheet.Name
            Else
                oListBox.AddItem "[非表示] " & oSheet.Name
            End If
        Next
        For Each oSheet In oBook.Excel4MacroSheets
            If oSheet.Visible = -1 Then
                oListBox.AddItem "[表示] " & oSheet.Name
            Else
                oListBox.AddItem "[非表示] " & oSheet.Name
            End If
        Next
        For Each oSheet In oBook.Excel4IntlMacroSheets
            If oSheet.Visible = -1 Then
                oListBox.AddItem "[表示] " & oSheet.Name
            Else
                oListBox.AddItem "[非表示] " & oSheet.Name
            End If
        Next

        If oListBox.ListCount = 0 Then
            MsgBox "モジュールは検出されませんでした。" _
                & Chr$(10) & Chr$(10) & vFileName, _
                vbInformation, myTitle
            GoTo Continue
        End If

        oDialogSheet.DialogFrame.Caption = _
            "モジュール一覧 - " & oBook.Name

        iDialogResult = 0

        oDialogSheet.Show

        If oCheckBox.Value = xlOn Then
            iRet = SetReadOnly(oBook)
            If iRet = 0 Then
                MsgBox "読み取り専用の設定でエラーが発生しました。", _
                    vbExclamation, myTitle
                oApp.Calculation = xlAutomatic
                GoTo Continue
            End If
        End If

        Select Case iDialogResult
            Case 0
                oBook.Close False
            Case 1
                oBook.RunAutoMacros xlAutoOpen
            Case 2
            Case 3
                iRet = RemoveModules(oBook)
                If iRet = 0 Then
                    MsgBox "モジュールの削除でエラーが発生しました。", _
                        vbExclamation, myTitle
                    oApp.Calculation = xlAutomatic
                    Exit Sub
                End If
        End Select

Continue:
    Next

    Application.Calculation = xlAutomatic

    Exit Sub

ErrorHandler:
    MsgBox Error(Err), vbExclamation, myTitle
    oApp.Calculation = xlAutomatic
    Exit Sub
End Sub


Sub Button1_Click()
    iDialogResult = CInt(Right$(Application.Caller, 2))
End Sub


Function SetReadOnly(oBook As Workbook) As Integer
    Dim oApp As Object

    On Error GoTo ErrorHandler
    SetReadOnly = 0
    Set oApp = Application

    If oBook.ReadOnly Then
        SetReadOnly = 1
        Exit Function
    End If

    Application.DisplayAlerts = False
    oBook.ChangeFileAccess Mode:=xlReadOnly
    Application.DisplayAlerts = True
    SetReadOnly = 1
    Exit Function

ErrorHandler:
    MsgBox Error(Err), vbExclamation, myTitle
    oApp.DisplayAlerts = True
    Exit Function
End Function


Function RemoveModules(oBook As Workbook) As Integer
    Dim oApp As Object
    Dim oSheet As Object
    Dim oName As Object
    Dim bFlag As Boolean
    Dim s As String

    On Error GoTo ErrorHandler
    RemoveModules = 0
    Set oApp = Application

    If oBook.ProtectStructure Then
        MsgBox "このブックは保護されています。", vbExclamation, myTitle
        Exit Function
    End If

    If (oBook.FileFormat = xlAddIn) Or (oBook.FileFormat = xlIntlAddIn) Then
        MsgBox "アドインファイルは編集できません。", vbExclamation, myTitle
        Exit Function
    End If

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlManual

    oBook.Windows(1).Visible = True

    bFlag = False
    For Each oSheet In oBook.Worksheets
        If oSheet.Visible = -1 Then
            bFlag = True
            Exit For
        End If
    Next
    If Not bFlag Then
        For Each oSheet In oBook.Charts
            If oSheet.Visible = -1 Then
                bFlag = True
                Exit For
            End If
        Next
    End If
    If Not bFlag Then
        oBook.Worksheets.Add
    End If

    For Each oName In oBook.Names
        s = UCase(oName.Name)
        If (s Like "AUTO_*") Or (s Like "*!AUTO_*") Then
            oName.Delete
        End If
    Next

    For Each oSheet In oBook.Modules
        oSheet.Visible = True
    Next
    For Each oSheet In oBook.Excel4MacroSheets
        oSheet.Visible = True
    Next
    For Each oSheet In oBook.Excel4IntlMacroSheets
        oSheet.Visible = True
    Next

    If oBook.Modules.Count > 0 Then
        oBook.Modules.Delete
    End If
    If oBook.Excel4MacroSheets.Count > 0 Then
        oBook.Excel4MacroSheets.Delete
    End If
    If oBook.Excel4IntlMacroSheets.Count > 0 Then
        oBook.Excel4IntlMacroSheets.Delete
    End If

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    RemoveModules = 1
    Exit Function

ErrorHandler:
    MsgBox Error(Err), vbExclamation, myTitle
    oApp.DisplayAlerts = True
    oApp.ScreenUpdating = True
    Exit Function
End Function


'ダイアログシートを作成するマクロ
Sub MakeDialogSheet()
    Dim oDialogSheet As DialogSheet
    Dim oSheet As Worksheet
    Dim dfGrid As Double
    Dim obj As Object

    Application.ScreenUpdating = False

    Set oDialogSheet = DialogSheets.Add
    With oDialogSheet
        .Name = "Dialog1"
        With .DialogFrame
            dfGrid = .Width / 60
            .Width = dfGrid * 80
            .Height = dfGrid * 43
            .Name = "Form1"
            .Caption = ""
        End With
        For Each obj In .DrawingObjects
            obj.Delete
        Next
    End With
    With oDialogSheet.ListBoxes.Add(1, 1, 1, 1)
        .Left = dfGrid * 18
        .Top = dfGrid * 11
        .Width = dfGrid * 43
        .Height = dfGrid * 33
        .Name = "ListBox01"
        .MultiSelect = xlNone
    End With
    With oDialogSheet.Buttons.Add(1, 1, 1, 1)
        .Left = dfGrid * 63
        .Top = dfGrid * 11
        .Width = dfGrid * 30
        .Height = dfGrid * 5
        .Name = "Button01"
        .OnAction = "Button1_Click"
        .Caption = "自動マクロを実行する"
        .DismissButton = True
        .CancelButton = False
        .DefaultButton = False
        .Accelerator = "E"
    End With
    With oDialogSheet.Buttons.Add(1, 1, 1, 1)
        .Left = dfGrid * 63
        .Top = dfGrid * 18
        .Width = dfGrid * 30
        .Height = dfGrid * 5
        .Name = "Button02"
        .OnAction = "Button1_Click"
        .Caption = "自動マクロを実行しない"
        .DismissButton = True
        .CancelButton = False
        .DefaultButton = False
        .Accelerator = "S"
    End With
    With oDialogSheet.Buttons.Add(1, 1, 1, 1)
        .Left = dfGrid * 63
        .Top = dfGrid * 25
        .Width = dfGrid * 30
        .Height = dfGrid * 5
        .Name = "Button03"
        .OnAction = "Button1_Click"
        .Caption = "マクロを削除する"
        .DismissButton = True
        .CancelButton = False
        .DefaultButton = False
        .Accelerator = "D"
    End With
    With oDialogSheet.Buttons.Add(1, 1, 1, 1)
        .Left = dfGrid * 63
        .Top = dfGrid * 32
        .Width = dfGrid * 30
        .Height = dfGrid * 5
        .Name = "Button04"
        .Caption = "開かない"
        .DismissButton = False
        .CancelButton = True
        .DefaultButton = False
        .Accelerator = "N"
    End With
    With oDialogSheet.CheckBoxes.Add(1, 1, 1, 1)
        .Left = dfGrid * 63
        .Top = dfGrid * 39
        .Width = dfGrid * 30
        .Height = dfGrid * 5
        .Name = "Check01"
        .Caption = "読み取り専用にする"
        .Accelerator = "R"
    End With
End Sub