- 帖子
- 519
- 主題
- 54
- 精華
- 0
- 積分
- 595
- 點名
- 251
- 作業系統
- win 10
- 軟體版本
- []
- 閱讀權限
- 50
- 性別
- 男
- 註冊時間
- 2013-3-19
- 最後登錄
- 2024-11-17
          
|
9#
發表於 2023-8-30 15:56
| 只看該作者
回復 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 |
|
