如何在MS Project中列出所有子程序及其所属模块名
MS Project宏库子程序列表生成方案
问题背景
我在独立的MS Project文件中按模块分组存储了大量实用宏,将其作为宏库使用。为遵循最佳实践,我希望在其他子程序中复用已有子程序,但每次都要花费时间在模块中查找目标宏。我需要生成包含子程序及其所属模块的列表,以便快速定位并使用Call Module.Sub语句调用到当前代码中。此前未找到相关方法,不知从何入手。
解决方案代码
更新:参考相关资料后,我找到了适配自身需求的代码,现将该代码附上,供有需要的用户参考:
'--------------------------------------------------------------------------------------- ' 功能 : 输出项目中所有子程序和函数 ' 前置条件: 需引用Microsoft Visual Basic for Applications Extensibility 5.3库 ' 运行方法: 运行X_GetFunctionAndSubNames,设置参数blnWithParentInfo ' 当ComponentTypeToString(vbext_ct_StdModule)返回"代码模块"时执行 '--------------------------------------------------------------------------------------- '基于现有代码修改而来 '主要修改:适配MS Project而非Excel,增加模块名称显示选项,将CreateLogFile改为Debug.Print输出 '添加了列表显示方式的选择功能 Option Explicit Private strSubsInfo As String Public Sub X_GetFunctionAndSubNames() Dim item As Variant strSubsInfo = "" Dim displaychoice As Integer displaychoice = InputBox("请选择模块名称的显示方式:" & vbCrLf & "1 = 与子程序名称同行,用':'分隔" & vbCrLf & "2 = 先显示模块名称,再列出该模块下的子程序") If Not (displaychoice = 1 Or displaychoice = 2) Then MsgBox ("只能选择1或2,程序将退出") Exit Sub End If For Each item In ThisProject.VBProject.VBComponents If ComponentTypeToString(vbext_ct_StdModule) = "代码模块" Then ListProcedures item.Name, displaychoice, False End If Next item Debug.Print strSubsInfo Clipboard (strSubsInfo) MsgBox ("子程序和模块名称已输出到立即窗口,并已复制到剪贴板") End Sub Private Sub ListProcedures(strName As String, displaychoice As Integer, Optional blnWithParentInfo = False) '运行此子程序需引用Microsoft Visual Basic for Applications Extensibility 5.3库 Dim VBProj As VBIDE.VBProject Dim VBComp As VBIDE.VBComponent Dim CodeMod As VBIDE.CodeModule Dim LineNum As Long Dim ProcName As String Dim ModuleName As String Dim ProcKind As VBIDE.vbext_ProcKind Set VBProj = ThisProject.VBProject Set VBComp = VBProj.VBComponents(strName) Set CodeMod = VBComp.CodeModule ModuleName = VBComp.CodeModule.Name If displaychoice = 2 Then strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & "模块 - " & ModuleName With CodeMod LineNum = .CountOfDeclarationLines + 1 Do Until LineNum >= .CountOfLines ProcName = .ProcOfLine(LineNum, ProcKind) If blnWithParentInfo Then If displaychoice = 2 Then strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & strName & "." & ProcName If displaychoice = 1 Then strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & strName & "." & ProcName & " : " & ModuleName Else If displaychoice = 2 Then strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & ProcName If displaychoice = 1 Then strSubsInfo = strSubsInfo & IIf(strSubsInfo = vbNullString, vbNullString, vbCrLf) & ProcName & " : " & ModuleName End If LineNum = .ProcStartLine(ProcName, ProcKind) + .ProcCountLines(ProcName, ProcKind) + 1 Loop End With End Sub Function ComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String '将组件类型枚举转换为可读字符串 Select Case ComponentType Case vbext_ct_ActiveXDesigner ComponentTypeToString = "ActiveX设计器" Case vbext_ct_ClassModule ComponentTypeToString = "类模块" Case vbext_ct_Document ComponentTypeToString = "文档模块" Case vbext_ct_MSForm ComponentTypeToString = "用户窗体" Case vbext_ct_StdModule ComponentTypeToString = "代码模块" Case Else ComponentTypeToString = "未知类型: " & CStr(ComponentType) End Select End Function Function Clipboard(Optional StoreText As String) As String '功能: 读写剪贴板 '实现逻辑:通过HTMLFile对象操作剪贴板 Dim x As Variant '存为Variant类型以支持64位VBA x = StoreText '创建HTMLFile对象 With CreateObject("htmlfile") With .parentWindow.clipboardData Select Case True Case Len(StoreText) > 0 '写入剪贴板 .setData "text", x Case Else '读取剪贴板(未传入参数时) Clipboard = .GetData("text") End Select End With End With End Function
内容的提问来源于stack exchange,提问作者Miles
相关产品推荐
相关产品推荐

