【VBADoc】ドキュメント自動生成ツール

Option Explicit
Option Base 1
Private clsProc() As clsProc
Private clsNum As Long

Sub VbaDoc()
    '''vbaドキュメントを自動生成する(クリップボードへ貼付け)
    '''再帰呼び出しは対応不可
    '''参照設定：Microsoft Visual Basic for Applications Extensibility
    
    clsNum = 0
    Erase clsProc
    Dim objVB As VBProject
    Set objVB = ThisWorkbook.VBProject
    
    ''インプット用の文字列を作成
    Dim strMsg As String, comp_i As Long
    For comp_i = 1 To objVB.VBComponents.Count
        strMsg = strMsg & comp_i & ": " & objVB.VBComponents.Item(comp_i).Name & vbLf
    Next
    strMsg = Left(strMsg, Len(strMsg) - 1) '末尾の改行削除
    
    Dim compNum As String
    compNum = InputBox("ドキュメント生成したいモジュールを選んでください" & vbLf & "（複数選択したい場合はカンマ区切り）" & vbLf & strMsg)
    
    ''プロシージャクラスを作成
    Dim strOneNum, lngOneNum As Long
    Dim oneComp As VBComponent, codeMdl As CodeModule
    On Error GoTo ErrorTrap '入力値がおかしければエラー処理
    For Each strOneNum In Split(compNum, ",")
        lngOneNum = CLng(strOneNum)
        Set oneComp = objVB.VBComponents.Item(lngOneNum)
        Set codeMdl = oneComp.CodeModule
        
        Call MakeProcCls(codeMdl) 'プロシージャクラスを作成
    Next
    On Error GoTo 0
    
    ''プロシージャ名リスト（カンマ区切り）の作成
    Dim i As Long, strProcName As String
    For i = 1 To clsNum
        strProcName = strProcName & clsProc(i).procName & ","
    Next
    strProcName = Left(strProcName, Len(strProcName) - 1)
    
    ''クラスのstrCallProcNameプロパティを入力
    Call LetCallProc(strProcName)
    
    ''アウトプット処理
    Dim strOut As String
    For i = 1 To clsNum
        With clsProc(i)
            strOut = strOut & .mdlName & "." & .procName & vbLf
            If .strAnnt <> "" Then
                strOut = strOut & "アノテーション" & vbLf & .strAnnt
                strOut = strOut & vbLf
            Else
                strOut = strOut & "アノテーション" & vbLf & "・無し" & vbLf
            End If
            
            If .strBlockComment <> "" Then
                strOut = strOut & "コードブロックコメント" & vbLf & .strBlockComment & vbLf
            Else
                strOut = strOut & "コードブロックコメント" & vbLf & "・無し" & vbLf
            End If
            
            If .strCallProcName <> "" Then
                strOut = strOut & "呼び出すプロシージャ" & vbLf & .strCallProcName & vbLf & vbLf
            Else
                strOut = strOut & "呼び出すプロシージャ" & vbLf & "・無し" & vbLf & vbLf
            End If
        End With
    Next
    SetCB strOut
    
    ''後処理
    For i = 1 To clsNum
        Set clsProc(i) = Nothing
    Next
    
    Exit Sub
    
ErrorTrap: MsgBox "数字以外を入力しないでください"
End Sub

Private Sub LetCallProc(ByVal strProcName As String)
    '''プロシージャで呼び出している他のプロシージャ名⇒strCallProcNameプロパティへ入力
    
    Dim arrProcName
    arrProcName = Split(strProcName, ",")
    Dim i As Long, line_i As Long, oneProcName
    For i = 1 To clsNum
        With clsProc(i)
            For Each oneProcName In arrProcName
                
                'プロシージャ名が自身⇒次のプロシージャ名へ
                If .procName = oneProcName Then GoTo NextProcName
                
                For line_i = .sRow To .eRow
                    Dim tmpLine As String
                    tmpLine = .codeMdl.Lines(line_i, 1)
                    
                    ''コード内に他のプロシージャ名があるか判定
                    'プロシージャ名の直前のスペースも確認
                    'コメントの場合を排除
                    If (tmpLine Like "* " & oneProcName & "*") And Not (tmpLine Like "*'*" & oneProcName & "*") Then
                        '2つ目以降は改行後にプロシージャ名を追加
                        If .strCallProcName <> "" Then .strCallProcName = .strCallProcName & vbLf
                        .strCallProcName = .strCallProcName & "・" & oneProcName
                        GoTo NextProcName 'マッチしたら次のプロシージャ名へ
                    End If
                Next
NextProcName:
            Next
        End With
    Next
End Sub

Private Sub MakeProcCls(codeMdl As CodeModule)
    '''プロシージャクラスを作成
    
    Dim strLine As String
    Dim procName As String, strAnnt As String
    Dim i As Long, sRow As Long
    For i = 1 To codeMdl.CountOfLines
        strLine = codeMdl.Lines(i, 1)
        
        ''インスタンス生成
        If JudgeProc(strLine) Then
            
            '要素数の変更
            clsNum = clsNum + 1
            If clsNum = 1 Then
                ReDim clsProc(clsNum)
            Else
                ReDim Preserve clsProc(clsNum)
            End If
            
            Set clsProc(clsNum) = New clsProc
            Set clsProc(clsNum).codeMdl = codeMdl
            clsProc(clsNum).mdlName = codeMdl.Parent.Name
            clsProc(clsNum).procName = GetProcName(strLine)
            clsProc(clsNum).sRow = i
        End If
        
        ''アノテーションとコードブロックコメントの取得
        If Left(Replace(strLine, " ", ""), 3) = "'''" Then
            '2つ目以降は改行後にアノテーションを追加
            If clsProc(clsNum).strAnnt <> "" Then clsProc(clsNum).strAnnt = clsProc(clsNum).strAnnt & vbLf
            clsProc(clsNum).strAnnt = clsProc(clsNum).strAnnt & "・" & Right(strLine, Len(strLine) - InStr(strLine, "'''") - 2)
        
        ElseIf Left(Replace(strLine, " ", ""), 2) = "''" Then
            '2つ目以降は改行後にコードブロックコメントを追加
            If clsProc(clsNum).strBlockComment <> "" Then clsProc(clsNum).strBlockComment = clsProc(clsNum).strBlockComment & vbLf
            clsProc(clsNum).strBlockComment = clsProc(clsNum).strBlockComment & "・" & Right(strLine, Len(strLine) - InStr(strLine, "''") - 1)
        End If
        
        '終了行の取得
        If (strLine Like "*End Sub*") Or (strLine Like "*End Function*") Then
            clsProc(clsNum).eRow = i
        End If
    Next
End Sub

Private Function GetProcName(strLine As String) As String
    '''プロシージャ名を返す
    
    ''SubとFunctionのどちらか判定
    Dim procState As String
    If (strLine Like "*Sub *") Then
        procState = "Sub "
    Else
        procState = "Function "
    End If
    
    Dim nameStart As Long, nameEnd As Long
    nameStart = InStr(strLine, procState)
    nameEnd = InStr(strLine, "(")
    GetProcName = Mid(strLine, nameStart + Len(procState), nameEnd - nameStart - Len(procState))
    
End Function

Private Function JudgeProc(strLine As String) As Boolean
    '''引数strLineがプロシージャの開始行か判定
    
    ''コメント⇒Falseを返す
    If Left(Replace(strLine, " ", ""), 1) = "'" Then Exit Function
    
    JudgeProc = (strLine Like "Sub *") Or (strLine Like "Function *") Or _
              (strLine Like "Private Sub *") Or (strLine Like "Private Function *") Or _
              (strLine Like "Public Sub *") Or (strLine Like "Public Function *")
End Function

Private Function GetRef() As String
    '''参照設定の一覧を返す
    
    GetRef = "参照設定" & vbLf
    
    Dim Ref
    For Each Ref In ThisWorkbook.VBProject.References
        GetRef = GetRef & "・" & Ref.Name & " : " & Ref.Description & vbLf
    Next
End Function

Public Sub SetCB(ByVal strSet As String)
'クリップボードにstrSetを貼り付ける
    '文字化け対策のためTextBoxを使用
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True '複数行入力可
        .Text = strSet
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
End Sub

Option Explicit
Public mdlName As String 'モジュール名
Public procName As String  'プロシージャ名
Public codeMdl As CodeModule 'コードモジュール
Public sRow As Long 'プロシージャの開始行
Public eRow As Long 'プロシージャの終了行
Public strAnnt As String 'アノテーション
Public strBlockComment As String 'コードブロックコメント
Public strCallProcName As String '呼び出すプロシージャ名