The Document of VBA, by VBA, for VBA（その2）

前回までのあらすじ

　VBAでVBEを操作する初期化が終わりました。

1.コードの走査

　前回に引き続き、各コンポーネントを走査していきます。

コードの走査

  For Each VBCom In wb.VBProject.VBComponents
    With VBCom.CodeModule
      If .CountOfDeclarationLines <> .CountOfLines Or _
         VBCom.Type = vbext_ct_ClassModule Or _
         VBCom.Type = vbext_ct_MSForm Then
        Dim cnt As Long: cnt = cnt + 1
        Call AddComponent2CallGraph(VBCom, cnt)
        Call getProcInfo(dicProcInfo, VBCom.CodeModule)
      End If
    End With
  Next VBCom

　VBComponentは各コンポーネントが該当するので、そのままだと何も書いていないシートモジュールなんかも走査してしまいます。
　まぁ大して時間の差にはならないと思いますが無駄なので、宣言部の行数とコード全体の行数が異なる場合のみ（宣言部以外で何か書かれている＝プロシージャがある）コードを走査します。
　宣言部だけある場合ってどういうことかというと例えばOption Explicitを自動で記載するようVBE側で設定しているときや、グローバル変数だけ一覧化した標準モジュールを作っているときなどが考えられます。
　ただし、この場合プロシージャのないフォームを参照する場合（インフォメーションを表示するためのオリジナルのフォームなど。完成品にはヘルプを表示するフォームがあります）等では参照先がコールグラフに表示されなくなるので、VBComponentのTypeプロパティを見てクラスとフォームの時はモジュールが記載されていなくても処理を続けます。
　走査対象のコンポーネントはコールグラフへの追加とプロシージャ情報の取得を行います。

CallGraphModule.AddComponent2CallGraph

Public Sub AddComponent2CallGraph(ByRef VBCom As Object, ByVal cnt As Long)
  Dim componentLeft As Single: componentLeft = getColPosition(cnt)
  Dim componentTop As Single: componentTop = PH + getRowPosition(1)
  Dim themeBrightness As Single
  Select Case VBCom.Type
  Case vbext_ct_ClassModule
    themeBrightness = -0.4
  Case vbext_ct_MSForm
    themeBrightness = -0.2
  Case Else
    themeBrightness = 0
  End Select

  Call setShape(VBCom.Name, C_Component, themeBrightness, S_Parent, _
                componentLeft, componentTop, CW, CH)
End Sub

　コンポーネントを順にコールグラフへ配置します。
　後にコンポーネントを走査する際に、そのコンポーネント内のプロシージャはこの時設置した各コンポーネントの下に順次配置していきます。

MainModule.getProcInfo

Private Sub getProcInfo(ByRef dic_proc_info As Object, ByRef VBCode As Object)
  CallGraph.Shapes(VBCode.Parent.Name).Select True
  Dim i As Long: i = VBCode.CountOfDeclarationLines + 1
  Do Until i > VBCode.CountOfLines
    Dim tmpProcName As String, tmpProcKind As Long: tmpProcName = VBCode.ProcOfLine(i, tmpProcKind)
    Dim procInfo As ClsProcInfo: Set procInfo = New ClsProcInfo
    With procInfo
      .ComponentName = VBCode.Name
      .ComponentType = VBCode.Parent.Type
      .ProcName = tmpProcName
      .DeclarationLineNo = VBCode.ProcBodyLine(tmpProcName, tmpProcKind)

      '宣言部の前にコメントがある時のみ取得
      If .DeclarationLineNo <> i Then _
         .ProcComment = VBCode.Lines(i, .DeclarationLineNo - i)

      .ProcDeclaration = getDeclarationPart(VBCode, .DeclarationLineNo)
      .ProcKind = tmpProcKind
      Dim procEndLine As Long: procEndLine = VBCode.ProcStartLine(tmpProcName, tmpProcKind) + _
                                             VBCode.ProcCountLines(tmpProcName, tmpProcKind)
      Set .ProcRelation = findRelationship(VBCode.Parent.Collection, VBCode, _
                                           .DeclarationLineNo, procEndLine)

      Dim procKey As String: procKey = .ComponentName & "." & .ProcName & convertPropertyKind(tmpProcKind)

      'モジュールをコードグラフへ追加
      Dim procCnt As Long: procCnt = procCnt + 1
      Call AddProc2CallGraph(.ComponentName, .ProcName, .ProcKindName, procCnt, procKey)
      CallGraph.Shapes(procKey).Select False

    End With
    dic_proc_info.Add procKey, procInfo

    i = procEndLine

    '進捗バーを進行
    pb.AddValue 1, ":" & VBCode.Parent.Name & "を調査中"
  Loop

  Call GroupingShapes(VBCode.Name, procCnt)
End Sub

　記載項目は、

• コンポーネント
• コンポーネントの種類
• プロシージャの名前
• プロシージャの種類
• プロシージャの宣言行数
• プロシージャの宣言部分
• プロシージャの引数
• プロシージャの戻り値
• プロシージャのコメント
• そのプロシージャが呼び出すプロシージャ・クラス・モジュール

　です。管理するためのクラスClsProcInfoを作成し、データとして格納した後Dictionaryに収納していきます。
　目からうろこ。（参考サイト）
　解説ポイントは次のあたり。

ProcOfLine(LineNumber, ProcKind)

ProcOfLineの使用例

    Dim tmpProcName As String, tmpProcKind As Long: tmpProcName = VBCode.ProcOfLine(i, tmpProcKind)

　ProcOfLineは「そのCodeModuleにおける行数がどのプロシージャの行数かを返すメソッド」返ってくるのはプロシージャ名です。説明もまぁややこしいですが、さらにややこしいのは第二引数のProcKindです。
　これにはプロシージャの種類（Sub/Function Let Set Get）を指定して渡しますが、指定することに大した意味はなく、プロシージャ内で結果が上書きされて返る仕様です。つまりメソッド1回のコールで名前と種別が返るという使い方ができます。
　これの何がややこしいかというと、ProcOfLine以外のProc～のメソッドではプロシージャとこのプロシージャの型をセットにして渡さないとエラーになるという点です。
　同じコンポーネント内に同名の別種のプロシージャは共存できないのでなんの意味があるのやら？

コメント

　いくつかのコーディングガイドラインを見ていて、得た感想は「命名規則をしっかりし、基本的にコードにはコメントを書かないほうが良い」ということです。そのため、コメントを残すことは無粋とも言えるわけです。
　宣言部分を見ればそのプロシージャが何を求め、何を残すのか凡そわかる（ようにコーディングする）ことが大切です。
　しかしながら、複雑なアルゴリズムやファイルの入出力など、どうしても宣言部分やコーディングだけでは表現しにくい部分もあるかと思います。というわけでコメントも取得できるようにしています。
　参考サイトでは宣言部分に連続したコメントを全てまとめて取得していますが、メソッドがあるので、もう少しスマートに取得しています。

コメントの取得

      .DeclarationLineNo = VBCode.ProcBodyLine(tmpProcName, tmpProcKind)

      '宣言部の前にコメントがある時のみ取得
      If .DeclarationLineNo <> i Then _
         .ProcComment = VBCode.Lines(i, .DeclarationLineNo - i)

　先頭行を調べるメソッドにはProcStartLineメソッドとProcBodyLineメソッドがあります。
　ProcStartLineメソッドは区切り線（宣言部同士の間に引かれる線）の下の行数が返ります。
　ProcBodyLineメソッドは宣言部の行数が返ります。
　したがってこの差がズバリ「宣言部の前に記載されたコメント」ということになります。
　今回は既にiに開始位置が入っているので、宣言部の行数を取得し、不一致ならコメントを取得します。
　続いて、コメント部分がわかったら整形します。
　先頭の’、空白、末尾の改行は削除します。Trimでは改行を削除できないので、自作のTrim関数を作成しています。
　また基本的に改行はそのままコメントとして扱いますが、末尾が_の場合は改行しません。

ClsProcInfo.ProcComment

''を削除し，コメントを整形する。
'ただしコメントの末尾が_（半角アンダーバー）の場合は改行を無視する。
Public Property Let ProcComment(ByVal comment As String)
  Dim tmp As Variant
  For Each tmp In Split(comment, vbNewLine)
    procComment_ = procComment_ & Mid(Trim(tmp), 2) & vbNewLine
  Next tmp
  procComment_ = myTrim(Replace(procComment_, "_" & vbNewLine, ""))
End Property

Private Function myTrim(ByVal mystr As String) As String
  Do While Right(mystr, Len(vbNewLine)) = vbNewLine
    mystr = Left(mystr, Len(mystr) - Len(vbNewLine))
  Loop
  Do While Left(mystr, Len(vbNewLine)) = vbNewLine
    mystr = Right(mystr, Len(mystr) - Len(vbNewLine))
  Loop
  myTrim = mystr
End Function

そのプロシージャが呼び出すプロシージャ・クラス・モジュール

　頑張ったポイント。
　各コンポーネントに含まれるモジュールとクラス・フォームが対象のプロシージャ内にあるかどうかを検索するメソッド。
　返り値は結果を格納したDictionaryオブジェクト。
　検索に当たっては各プロシージャごとに全プロシージャ・クラス・モジュールがあるかを調べるため、N^2のオーダーになります。コードが増えれば増えるほど時間がかかるので注意してください（何かいい方法はないかしら）。
　ちなみに、169プロシージャではうまくいきました。
　CodeModuleの配下にはプロシージャがいないため、CodeModule自身と宣言行と、プロシージャの行数で対象プロシージャを管理します。

関係性調査

      Set .ProcRelation = findRelationship(VBCode.Parent.Collection, VBCode, _
                                           .DeclarationLineNo, procEndLine)

　わざわざCodeModuleをややこしい管理にしてしまうのはCodeModuleにはFindメソッドがあるからです。
　CodeModuleのFindメソッドは開始行・開始列・終了行・終了列を指定して、CodeModuleのその範囲内に特定の文字が含まれているかどうかを検索するメソッドです。
　Findの結果が返る他、範囲として指定した、開始行・開始列・終了行・終了列が見つかった個所で上書きされるという何とも複雑な仕様です。
　また部分一致か全体一致を指定する引数がありますが、全体一致としていても末尾の_が引っかかる仕様です。
　これはフォームやインターフェースの「クラス名_Initialize()」のようなメソッドをクラス名で検索するためかと思われます。（未確認）

findRelationship

'target_codeのstart_lineとend_lineの間が対象プロシージャ
'対象のプロシージャ内にVBCollectionのすべてのクラス，フォームと_
'全モジュールが登場するかを検索し，Dictionaryオブジェクトを返す
Private Function findRelationship(ByRef VBCollection As Object, ByRef target_code As Object, _
                                  ByVal start_line As Long, ByVal end_line As Long) As Object
  Dim tmpdic As Object: Set tmpdic = CreateObject("Scripting.Dictionary")
  tmpdic.Add "Module", ""
  tmpdic.Add "Class", ""
  tmpdic.Add "Form", ""
  #If DebugMode Then
    Dim tmp As VBComponent
  #Else
    Dim tmp As Object
  #End If
  For Each tmp In VBCollection
    Dim sl As Long: sl = start_line + 1
    Dim sc As Long: sc = 0
    Dim el As Long: el = end_line - 1
    Dim ec As Long: ec = 0

    If target_code.Find(tmp.Name, sl, sc, el, ec, True, True) Then
      Select Case tmp.Type
      Case vbext_ct_ClassModule
        tmpdic("Class") = tmpdic("Class") & tmp.Name & vbNewLine
      Case vbext_ct_MSForm
        tmpdic("Form") = tmpdic("Form") & tmp.Name & vbNewLine
      End Select
    End If

    '全モジュールが存在するか検索
    Dim i As Long: i = tmp.CodeModule.CountOfDeclarationLines + 1
    Do Until i > tmp.CodeModule.CountOfLines
      Dim tmpProc As String, tmpKind As Long
      tmpProc = tmp.CodeModule.ProcOfLine(i, tmpKind)

      If isExistProc(target_code, start_line, end_line, tmpProc, tmpKind) Then
        tmpdic("Module") = tmpdic("Module") & tmp.Name & "." & tmpProc & _
                                            convertPropertyKind(tmpKind) & vbNewLine
      End If

      i = i + tmp.CodeModule.ProcCountLines(tmpProc, tmpKind)
    Loop

  Next tmp
  Set findRelationship = tmpdic
End Function

　クラスとフォームとは異なり、プロシージャはもう少しややこしいことが実装しながらわかったので、プロシージャの存在確認はさらに別プロシージャで独立させています。
　ややこしかったとは次のケース。

次が_（半角アンダースコア）

　Findメソッドでは全体一致としていてもなぜかは無視されます。そのためプロシージャ名という変数があった場合ヒットします。
　個人的にはクラスモジュールのPrivate引数に使っていたのでハマりました。
　Class_Initializeのようなあらかじめ_が入っているメソッドはClass_Initializeとして検索するので問題ないはずです。Findメソッドのこの仕様はどこにも見つからなかったので、他にも正しく検索されない文字があるかもしれません。

対象のプロシージャ名＝

　Function、Property Getでは返り値として「自分自身＝」の記載があります。単純に「プロシージャ名があるかどうか」だけ検索してしまうとこれを拾ってしまうため、無視します。
　あらかじめ自分自身を省いてしまえば？　とも思いましたが、再帰するパターンもあるため、自分自身が呼び出されているかどうかも検索する必要があります。

対象のプロシージャがProperty

Property大きく値設定用のSet/Letと値取得用のGetに分かれます。読み取り専用のプロパティ（Getのみ）は良いですが、書き込み専用のプロパティ（Set/Letのみ）は基本的には想定されておらず、また読み書きできるプロパティは普通に存在しえます。
　Propertyは基本的に同じ名前で宣言するので、プロシージャ名だけで検索するとどちらかわからないということが起こりえます。
　見つかったプロシージャがSetまたはLetである場合、次は必ず＝になるはずなので、種別とともに調べます。

（9/1追記）

　Findメソッドですが、指定した範囲がそのコンポーネントの範囲を超えると勝手に全体に置き換わるようです。
　修正前は実行のたびに上書きされる検索結果elを対象プロシージャ最終行（end_line）に毎回戻していましたが、これだと最後のメソッドの後に何も記載がない場合（最終行がEnd Sub等のとき）、関係性の検索がうまくいきません。end_lineの1行前に修正しました。

isExistProc

Private Function isExistProc(ByRef target_code As Object, ByVal start_line As Long, ByVal end_line As Long, _
                     ByVal tmp_proc As String, ByVal tmp_proc_kind As Long) As Boolean
  Dim targetProc As String: targetProc = target_code.ProcOfLine(start_line, 0)
  Dim tmp As Boolean: tmp = False

  Dim sl As Long: sl = start_line + 1
  Do
    Dim sc As Long: sc = sc + IIf(sc = 0, 1, 2)
    Dim el As Long: el = end_line - 1
    Dim ec As Long: ec = 0

    Dim isFound As Boolean: isFound = target_code.Find(tmp_proc, sl, sc, el, ec, True, True)

    'FindメソッドがTrueであったとしてもいくつか除外するパターンがあるため分岐
    If isFound And el <> end_line Then
      If Mid(target_code.Lines(el, 1), ec, 1) = "_" Then
        '直後が"_"のときは無視
        isFound = False
      ElseIf Mid(target_code.Lines(sl, el - sl + 1), sc, ec - sc + Len(" = ")) = _
                                                                               targetProc & " = " Then
        '"対象プロシージャ = "の場合はFunctionかGetの戻り値なので、無視する
        isFound = False
      ElseIf tmp_proc_kind <> vbext_pk_Proc Then
        'Propertyは同じ名前になるので種別まで確認する。
        isFound = tmp_proc_kind = vbext_pk_Get Xor _
                  isLetOrSet(Mid(target_code.Lines(sl, end_line - sl + 1), ec))
      End If
    End If

    tmp = tmp Or isFound
  Loop While el <> end_line - 1

  isExistProc = tmp
End Function

コードグラフ用にグループ化する

　コードグラフで扱えるようコンポーネントとその配下のプロシージャをグループ化しておきます。
　ShapeオブジェクトのSelectメソッドは引数をTrueとすると新規に、Falseにすると既存の選択範囲に追加して選択ができます。
　コンポーネントの走査が始まったときにコンポーネント自体をTrueで選択し、追加したプロシージャはそのコンポーネントの配下に配置するとともに引数FalseでSelectしていきます。
　こうすることで、そのコンポーネントの走査が終わったときにはそのコンポーネントとそのコンポーネント配下だけが選択されている状態になるので、Groupingメソッドでグループ化します。
　配下にメソッドがない場合はグループ化できないのでエラー処理します。

コードのグループ化

  CallGraph.Shapes(VBCode.Parent.Name).Select True
（略）
      'モジュールをコードグラフへ追加
      Dim procCnt As Long: procCnt = procCnt + 1
      Call AddProc2CallGraph(.ComponentName, .ProcName, .ProcKindName, procCnt, procKey)
      CallGraph.Shapes(procKey).Select False

（略）
  Call GroupingShapes(VBCode.Name, procCnt)

CallGraphModule.bas

Public Sub AddProc2CallGraph(ByVal component_name As String, ByVal proc_name As String, _
                             ByVal proc_kind_name As String, ByVal cnt As Long, _
                             ByVal shape_name As String)
  Dim ThemeColor As Long, ProcKind As Long
  Select Case proc_kind_name
  Case "Sub"
    ThemeColor = msoThemeColorAccent1
  Case "Function"
    ThemeColor = msoThemeColorAccent2
  Case "Let"
    ThemeColor = msoThemeColorAccent4
  Case "Set"
    ThemeColor = msoThemeColorAccent4
  Case "Get"
    ThemeColor = msoThemeColorAccent6
  End Select

  With CallGraph.Shapes(component_name)
    Dim procTop As Single: procTop = .Top + .Height - PT + getRowPosition(cnt)
    Const MARGIN As Single = 5
    Call setShape(proc_name, ThemeColor, 0.6, msoShapeRectangle, _
                  .Left + MARGIN, procTop, CW - MARGIN * 2, CH, shape_name)
  End With

End Sub

Public Sub GroupingShapes(ByVal group_name As String, Optional ByVal proc_cnt As Long = 1)
  On Error GoTo Err_Handler
  With Selection.ShapeRange
    .Group
    .Name = "G_" & group_name
  End With
  With CallGraph.Shapes.Item(group_name)
    .Height = (CT + CH) * (proc_cnt + 1) + CT
    .TextFrame2.VerticalAnchor = msoAnchorTop
  End With
Err_Handler:
End Sub

次回予告

　今回の結果でdicProcInfoにコードの走査結果、CallGraphのシートにコンポーネントとその配下のプロシージャが判例とともに記載されます。これでやりたいことの7割くらい終了しました。
　次回はいよいよコールグラフの作成です。