[發問] VBA專案內程序調用關係

Scott090

請問如何產生如下的VBA程序調用的關係表
      

下載 (100.06 KB)
程序調用關係表

2023-4-18 10:01

    說明：
            1. 一個VBA專案內可能有許多模組如圖表中的 行"A"，
            2. 各模組內有有許多子程序 sub( )、function( ) 如圖表中的 行 "B"
            3. 表中的模組名稱及程序名稱是為說明虛擬的            
            4. 程序中會呼叫調用，程序多了就難找到本程序是用到哪一個模組內的那一個程序；
                反之，一個程序調用某一個程序卻不知在那一個模組內。時間久了要做修改或 debug就困擾了。
                (當然，在寫程序時多加備註就好了，哈哈。)
            5. 舉例，上圖表中表示 此VBA專案有 A 行中 3個模組(Mod1,Mod2,Mod3)，
                 B 行中各模組內有其 子程序(sub11( ),sub12( ).......sub33( ),函數 (fun13,.....,fun36( )  )，
                 第2列， 位於模組Mod1 內的子程序 sub11( ) 被 位於 模組 Mod3 的 sub31( ) 及 模組 Mod3 的 sub33( ) 調用
                 第3列 ， Mod1內的 sub12( ) 沒被調用 ，也許有調用其他程序
                  .
                  .
                  第16列， 模組 Mod3 內的函數 fun36( ) 有被 Mod2 的fun24( ) 及 Mod3 的 sub31( ) 及 Mod3 的 fun35( ) 調用。

          請大大們協助幫忙。
           感恩

Scott090

回復 1# Scott090

     先研擬解題策略
1. 先從本workbook 之 VBComponents 取得 各類 Module、Class 及其中的 sub、function、property
     確定workbook有那一些 模組及其子程序等。
2. 把 在第1. 內取得的 模組及各自的 子程序、函數 等 放入 字典。
3. 從 VBComponents 內的 每條 code statement 比對到 字典取出 哪一個 模組的哪一個 sub、function 等的名稱被調用了。
4. 2 個注意點是 備註 或 用 " : " 連串再一起的 程序碼語句
5. 整理第3. 的結果 可得 哪一的模組的哪一個子程序等被 哪一個子程序等調用
6. 完成 問題的 調用表

    以上僅供大大們參考 並 指導
   
    謝謝

Andy2483

回復 2# Scott090

謝謝前輩發表此主題
後學有複雜調用案子,很想學這帖關係表的知識,請前輩指導,謝謝前輩
請教前輩:
1. 先從本workbook 之 VBComponents 取得 各類 Module、Class 及其中的 sub、function、property
     確定workbook有那一些 模組及其子程序等。
後學有找到 http://forum.twbts.com/viewthrea ... ght=VBComponents%2B
這帖 阿龍前輩的解答,但是只有(活頁簿名稱,模組名稱,程序名稱),這樣好像無法知道調用關係,請前輩指導

執行結果:

下載 (26.13 KB)

2023-4-20 15:54

Sub 找巨集名稱()
Application.DisplayAlerts = False
[A1] = "活頁簿名稱"
[B1] = "模組名稱"
[C1] = "程序名稱"
R = 2
Set WB = ThisWorkbook
  For Each VBC In WB.VBProject.VBComponents
    Select Case VBC.Type
      Case 1  '1=一般模組
        LS = VBC.CodeModule.CountOfLines
        'Debug.Print LS
        LineStr = VBC.CodeModule.Lines(1, LS)
        Lines = Split(LineStr, vbCrLf)
        For Each Line In Lines
            If Line Like "Sub*" Then
              Cells(R, 1) = WB.Name
              Cells(R, 2) = VBC.Name
              Cells(R, 3) = Line
              R = R + 1
            End If
        Next 'Line
      Case Else
    End Select
  Next  'VBC
Columns.AutoFit
End Sub

Scott090

回復 3# Andy2483

  大大貼的程序我有拜讀過。
  因為尚無高人協助解答，所以我先提出自己的構思方向，需要繼續努力去求得解方。
  
一起努力吧，期望有好結果
    當然如有高人願給指導，非常感恩

Andy2483

回復 4# Scott090


    謝謝前輩回復
前輩知道如何將vba的程式碼匯到工作表儲存格裡嗎?

Scott090

回復 5# Andy2483

把 3# 樓的程式碼修改如下 測試。
  Sub 找巨集名稱()
Application.DisplayAlerts = False
'[A1] = "活頁簿名稱"
'[B1] = "模組名稱"
'[C1] = "程序名稱"
R = 1  '2
ActiveSheet.Cells.Clear
Set WB = ThisWorkbook
  For Each VBC In WB.VBProject.VBComponents
    Select Case VBC.Type
      Case 1  '1=一般模組
        LS = VBC.CodeModule.CountOfLines
        'Debug.Print LS
        LineStr = VBC.CodeModule.Lines(1, LS)
        Lines = Split(LineStr, vbCrLf)
               
        For Each Line In Lines
            Cells(R, 1) = IIf(Left(Line, 1) = "'", "'" & Line, Line)  '避免備註符號 ' 在儲存格被視為一般文字格式

'            If Line Like "Sub*" Then
'              Cells(R, 1) = WB.Name
'              Cells(R, 2) = VBC.Name
'              Cells(R, 3) = Line
              R = R + 1
'            End If
        Next 'Line
      Case Else
    End Select
  Next  'VBC
Columns.AutoFit
End Sub

Andy2483

回復 6# Scott090


    謝謝前輩指導,後學有測試成功
目前感覺#3樓 + #6樓的輸出結果可以抓出一般模組的程序調用關係

不知道有沒有類似樹狀關係圖可以查看,不然像專業複雜點的程式怎麼管理?
後學學得太淺了,謝謝前輩

Scott090

回復 7# Andy2483


    請參照 2# 的 思考：
            2. 把 在第1. 內取得的 模組及各自的 子程序、函數 等 放入 字典。
            3. 從 VBComponents 內的 每條 code statement 比對到 字典取出 哪一個 模組的哪一個 sub、function 等的名稱被調用了。

      謝謝

Scott090

回復 7# Andy2483

  取出各模組內的程序，再做交叉比對。
  但每人寫程式的風格不同，應該需要另行考慮修飾或有其他更好的做法。
  以下是我自己成功測試用程式， 請測試自己的專案程式試試看。
  
'參考 https://ithelp.ithome.com.tw/questions/10202519
    Option Explicit
Option Base 1

Private Sub GetModules()
    Dim wb As Workbook, sh As Worksheet
    Dim k&, RowNum%, c
    Dim VBC, CodeStrs
    Dim arrProc$(), arrB
    Set wb = ThisWorkbook
    Set sh = Sheets("MacroList")    '程序調用工作表
    sh.Cells.Clear
    sh.Select
    Range("A1").Select
   
    Set VBC = wb.VBProject.VBComponents
    RowNum = 0
    ReDim arrProc(5, 1)
    For Each c In VBC
         RowNum = ListProcedures(c.CodeModule.Name, RowNum, arrProc)
    Next
   
    Call 程序調用表(arrProc)

       '把交叉子程序調用表放入工作表 "MacroList"
     [A1:E1] = Array("模組名", "被調程序名", "程序類別", "模組起始行，行數", "調用模組.程序")
   
    '凍結第一列 欄位名稱
    Range("A2").Select
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

    [A2].Resize(RowNum, 5) = Application.Transpose(arrProc)
    Set wb = Nothing  
End Sub

Function ListProcedures(ModuleName$, RowNum%, arrProc) As Integer   
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    Dim LineNum&, lineStr$, CodeStrs, startLineNum&, endLineNum&
    Dim ProcLineCount&, LS&
    Dim sh As Worksheet
    Dim Rng As Range
    Dim ProcName As String
    Dim ProcKind As vbext_ProcKind   '程序種類 modules, sub( ) or function( ),property get,property Let, property set
   
    Set VBProj = ActiveWorkbook.VBProject
    Set VBComp = VBProj.VBComponents(ModuleName)    'VBComp 是 模組名稱內的元件
    Set CodeMod = VBComp.CodeModule
    Set sh = ActiveWorkbook.Worksheets("MacroList")         '設定一調用表的工作表
    sh.Select
   
    LS = CodeMod.CountOfLines       '這個模組內(所有的程序)程式碼語句的行數
        '有模組名但沒有程序碼則跳過
    If LS = 0 Then GoTo ExitFunction   
  
   With CodeMod        '在這個模組內
      LineNum = .CountOfDeclarationLines + 1    '程序前的宣告列及備註列數
      Do Until LineNum >= .CountOfLines         'CountOfLines 模組程序碼總行數
        RowNum = RowNum + 1
        ReDim Preserve arrProc(5, RowNum)
        ProcName = .ProcOfLine(LineNum, ProcKind)   '程序內任何行碼 LineNum 可搜尋程序名稱
        arrProc(1, RowNum) = ModuleName: arrProc(2, RowNum) = ProcName: arrProc(3, RowNum) = ProcKindString(ProcKind)
               
        startLineNum = .ProcBodyLine(ProcName, ProcKind)   '程序開始行碼
        ProcLineCount = .ProcCountLines(ProcName, ProcKind)    '程序行數
'        endLineNum = .ProcendLine(ProcName, ProcKind)
        arrProc(4, RowNum) = startLineNum & ", " & ProcLineCount
        
'        Cells(RowNum + 1, "D") = startLineNum & ", " & ProcLineCount
        LineNum = startLineNum + ProcLineCount + 1         '同一模組之下一個程序開始行碼 程序開始數 + 程序長度
      Loop
    End With
ExitFunction:
    ListProcedures = RowNum
End Function


Function ProcKindString$(ProcKind As VBIDE.vbext_ProcKind) 'As String
    Select Case ProcKind
      Case vbext_pk_Get
          ProcKindString = "Property Get"
      Case vbext_pk_Let
          ProcKindString = "Property Let"
      Case vbext_pk_Set
          ProcKindString = "Property Set"
      Case vbext_pk_Proc
          ProcKindString = "Sub Or Function"
      Case Else
          ProcKindString = "Unknown Type: " & CStr(ProcKind)
    End Select
End Function

'參考 Searching For Text In A Module   http://www.cpearson.com/excel/vbe.aspx
Sub 程序調用表(arrProc)      '(FindWhat$)       '搜尋 調用的子程序與函數名稱字串
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponents
    Dim VBC              'As Object
    Dim CodeMod As VBIDE.CodeModule
    Dim ProcName As String
    Dim ButtonStr$                          '自訂另列 Command Bar 按鈕字串
    Dim ProcKind As VBIDE.vbext_ProcKind   '程序種類 modules, sub( ) or function( ),property get,property Let, property set
    Dim wb As Workbook
    Dim lineStr$, CodeStrs, Proc
    Dim i&, j&, RowNum&, comma$
    Dim SL&, SL0& ' start line
    Dim EL& ' end line
    Dim SC&, SC0& ' start column
    Dim EC&, EC0& ' end column
    Dim Found As Boolean
        
    '引用項： Microsoft Visual Basic for Applications Extensibility 5.3
    '    AddExtenReference   '加入引用項
    Set wb = ThisWorkbook
    Set VBProj = wb.VBProject
    Set VBComp = VBProj.VBComponents    '(ModuleNames)
   
    For i = 1 To UBound(arrProc, 2)
'        Debug.Print arrProc(2, i)
        comma = ""
        For Each VBC In VBComp
            Set CodeMod = VBC.CodeModule
            With CodeMod
            
                '本模組是否有程式碼
                If .CountOfLines < 2 Then GoTo next_VBC
        '========== 設定搜尋起始點 ==========================================================
                SC0 = 1 '已搜尋文字串的上一個位置
                SL = .CountOfDeclarationLines + 1   '從宣告行後的第一行開始搜尋
                EL = .CountOfLines
                SC = 0: EC0 = 0: EC = 1023
               
                Found = .Find(Target:=arrProc(2, i), _
                    startline:=SL, StartColumn:=SC, EndLine:=EL, EndColumn:=EC, _
                    wholeword:=True, MatchCase:=True, patternsearch:=False)
               
                '在同一模組內反覆搜尋
                Do Until Found = False
                    If SL = Split(arrProc(4, i), ",")(0) Then GoTo 101        '找到的是程序或函數定義本身的名稱
                    lineStr = Trim(Left(.Lines(SL, 1), SC - 1)) '找到的字串前面的字串
                    
                     '自訂另列Command Bar 按鈕字串
                    If InStr(lineStr, "OnAction =") <> 0 Then
                        ButtonStr = ". " & Replace(Mid(Trim(.Lines(SL - 1, 1)), 12), Chr(34), "")  'len(".caption = ") =11
                        GoTo 100
                    End If
                    
'                    字串有 "' "、"Sub"、 "Function"、 ' "'則找到的字串可能不是在呼叫程序或是程序頭
                    If InStr(lineStr, Chr(39)) <> 0 Or _
                       InStr(lineStr, "Sub") <> 0 Or _
                       InStr(lineStr, "Function") Or _
                       Right(lineStr, 1) = Chr(34) Then GoTo 101
100
                    ProcName = .ProcOfLine(SL, ProcKind)    '搜尋到的字串在那個子程序或函數
                    If ProcName <> arrProc(2, i) Then
                       arrProc(5, i) = arrProc(5, i) & comma & .Name & "." & ProcName & ButtonStr
                        comma = ", ": ButtonStr = ""
                    End If
                    
                    '在找到字串的同一行的下一個字繼續搜尋
                    EL = .CountOfLines
                    SC = EC:  EC = 1023
                    GoTo 102
101
                    '從下一行的起始列繼續搜尋
                    SL0 = SL: SL = SL + 1
                    SC0 = 0: SC = 0
                    EC0 = 0: EL = .CountOfLines
                    EC = 1023        '最多一字串之限定長度 1023個字
102
                    Found = .Find(Target:=arrProc(2, i), startline:=SL, StartColumn:=SC, _
                        EndLine:=EL, EndColumn:=EC, _
                        wholeword:=True, MatchCase:=True, patternsearch:=False)
                Loop
            End With
next_VBC:
        Next  'Module
Next_i:
    Next     'i ,next Procedure being called
   
End Sub