'プロシージャの一覧を作成するマクロ

'アクティブブックのプロシージャ一覧を作成します。

Option Explicit

Sub MyProcedureList()
    Const myTitle As String = "プロシージャリストの作成"
    Const tmpfilename As String = "myproc.tmp"
    Dim filename As String
    Dim book1 As Workbook, module1 As Module
    Dim outputRange As Range
    Dim fno As Integer
    Dim cnt As Integer
    Dim i As Integer, j As Integer
    Dim s As String

    On Error GoTo err_1

    filename = Application.DefaultFilePath
    If Right$(filename, 1) <> "\" Then filename = filename & "\"
    filename = filename & tmpfilename

    If Dir$(filename) <> "" Then
        MsgBox "一時ファイル " & filename & " が既に存在します。", _
            vbExclamation, myTitle
        Exit Sub
    End If

    Application.ScreenUpdating = False

    Set book1 = ActiveWorkbook
    Set outputRange = Workbooks.Add(xlWorksheet).Worksheets(1).Cells(2, 1)
    outputRange.Worksheet.Cells.Clear
    With outputRange.Cells(0, 1).Resize(1, 4)
        .Value = Array("Book", "Module", "Procedure", "Type")
        .Font.Bold = True
    End With
    cnt = 0

    For Each module1 In book1.Modules
        Application.DisplayAlerts = False
        module1.SaveAs filename:=filename, FileFormat:=xlText
        Application.DisplayAlerts = True

        fno = FreeFile()
        Open filename For Input As #fno
        Line Input #fno, s
        Do While Not EOF(fno)
            If s Like "Sub *" Then
                i = 5
            ElseIf s Like "Function *" Then
                i = 10
            Else
                i = 0
            End If
            If i <> 0 Then
                j = InStr(i, s, "(", 0)
                If j = 0 Then j = Len(s) + 1
                cnt = cnt + 1
                outputRange.Cells(cnt, 1).Value = "'" & module1.Parent.FullName
                outputRange.Cells(cnt, 2).Value = "'" & module1.Name
                outputRange.Cells(cnt, 3).Value = "'" & Mid$(s, i, j - i)
                outputRange.Cells(cnt, 4).Value = "'" & Mid$(s, 1, i - 1)
            End If
            Line Input #fno, s
        Loop
        Close #fno
    Next
    If Dir$(filename) <> "" Then Kill filename
    outputRange.Worksheet.Columns.AutoFit
    Exit Sub
err_1:
    Close #fno
    MsgBox Error(Err) & " (" & Err & ")", vbExclamation, myTitle
End Sub