如何修改VBA代码提取Sub与Function的完整代码体？

我正在开发一个工具，用来删除VBA中未使用的Sub和Function，目前卡在提取完整代码体的阶段。现有代码能获取所有Sub/Function的名称，但拿不到完整代码，而且看不懂代码逻辑没法修改。现有代码如下：

Sub sbGetListOfProcedures()

    Dim obj As AccessObject
    Dim dbs As Object
    Dim strMdl() As String
    Dim Idx As Integer
    Dim vrFormName As String

    Set dbs = Application.CurrentProject

    ReDim strMdl(0)

    For Each obj In dbs.AllModules
        strMdl(UBound(strMdl)) = obj.Name
        ReDim Preserve strMdl(UBound(strMdl) + 1)
    Next obj

    ReDim Preserve strMdl(UBound(strMdl) - 1)

    Dim strSQL As String
    sbWOff
    strSQL = "Delete * from ZProcedures;"
    DoCmd.RunSQL strSQL

    sbWOn
    Application.Echo False
    While Idx <= UBound(strMdl)
        fnFindProcedure (strMdl(Idx))
        Idx = Idx + 1
    Wend
    Application.Echo True
  
    For Each obj In dbs.AllForms
        vrFormName = obj.Name
        DoCmd.OpenForm vrFormName, acDesign, , , , acHidden
        If Forms(vrFormName).HasModule = True Then
            fnFindProcedure ("Form_" & vrFormName)
        End If
        DoCmd.Close acForm, vrFormName, acSaveNo
    Next obj
    
End Sub

Function fnFindProcedure(vrModuleName As String)

    Dim obj As AccessObject
    Dim dbs As Object

    Dim DAOdb As DAO.database
    Dim vrRs1 As DAO.Recordset
    Dim vrModule As Module
    Dim vrIdx As Long
    Dim vrJdx As Long
    Dim vrMyLine As String
    Dim vrProc As Integer
    Dim vrProcLn(5) As String

    vrProcLn(0) = "Private Sub"
    vrProcLn(1) = "Private Function"
    vrProcLn(2) = "Public Sub"
    vrProcLn(3) = "Public Function"
    vrProcLn(4) = "Sub"
    vrProcLn(5) = "Function"

    Set dbs = Application.CurrentProject
    Set DAOdb = CurrentDb
    Set vrRs1 = DAOdb.OpenRecordset("ZProcedures", dbOpenDynaset)

    vrIdx = 1
    DoCmd.OpenModule (vrModuleName)
    Set vrModule = Modules(vrModuleName)
    While vrIdx <= vrModule.CountOfLines
        vrMyLine = vrModule.Lines(vrIdx, 1)

        vrJdx = 0
        Do While vrJdx <= UBound(vrProcLn)
            vrProc = InStr(vrMyLine, vrProcLn(vrJdx))
            If (vrProc = 1) Then
                With vrRs1
                Debug.Print vrMyLine
                    .AddNew
                    !ModuleName = vrModuleName
                    !ProcedureCall = vrMyLine
                    ' !ProcedureTxt = vrModule
                    .Update
                End With
                Exit Do
            End If
            vrJdx = vrJdx + 1
        Loop

        vrIdx = vrIdx + 1
    Wend
    DoCmd.Close acModule, vrModuleName

End Function

现有代码逻辑拆解 #

• sbGetListOfProcedures：
  • 收集当前Access项目里所有标准模块的名称，存到数组中
  • 清空ZProcedures表的所有数据
  • 遍历每个标准模块，调用fnFindProcedure处理
  • 遍历所有窗体，对带代码模块的窗体，用Form_+窗体名作为模块名，调用fnFindProcedure处理
• fnFindProcedure：
  • 定义6种Sub/Function的开头关键词（Private/Public/无修饰的Sub/Function）
  • 打开指定模块，逐行扫描代码
  • 找到以关键词开头的行，就把模块名和该行内容存入ZProcedures表
  • 核心问题：只抓取了过程的定义行，没获取从定义到End Sub/End Function的完整代码体，且逐行扫描容易误判（比如注释里的关键词）

修改后的代码（支持提取完整过程代码） #

用VBA的Module对象自带的ProcStartLine和ProcCountLines方法，精准定位每个过程的起始行和总行数，直接提取完整代码：

Sub sbGetListOfProcedures()

    Dim obj As AccessObject
    Dim dbs As Object
    Dim strMdl() As String
    Dim Idx As Integer
    Dim vrFormName As String

    Set dbs = Application.CurrentProject

    ReDim strMdl(0)

    For Each obj In dbs.AllModules
        strMdl(UBound(strMdl)) = obj.Name
        ReDim Preserve strMdl(UBound(strMdl) + 1)
    Next obj

    ReDim Preserve strMdl(UBound(strMdl) - 1)

    Dim strSQL As String
    sbWOff
    strSQL = "Delete * from ZProcedures;"
    DoCmd.RunSQL strSQL

    sbWOn
    Application.Echo False
    Idx = 0 ' 修正原代码未初始化Idx的问题
    While Idx <= UBound(strMdl)
        fnFindProcedure strMdl(Idx) ' 去掉多余括号，避免参数强制转Variant
        Idx = Idx + 1
    Wend
    Application.Echo True
  
    For Each obj In dbs.AllForms
        vrFormName = obj.Name
        DoCmd.OpenForm vrFormName, acDesign, , , , acHidden
        If Forms(vrFormName).HasModule = True Then
            fnFindProcedure "Form_" & vrFormName ' 去掉多余括号
        End If
        DoCmd.Close acForm, vrFormName, acSaveNo
    Next obj
    
End Sub

Function fnFindProcedure(vrModuleName As String)

    Dim DAOdb As DAO.Database
    Dim vrRs1 As DAO.Recordset
    Dim vrModule As Module
    Dim vrProcName As String
    Dim vrProcType As vbext_ProcType
    Dim vrStartLine As Long
    Dim vrLineCount As Long
    Dim vrFullCode As String

    Set DAOdb = CurrentDb
    Set vrRs1 = DAOdb.OpenRecordset("ZProcedures", dbOpenDynaset)

    DoCmd.OpenModule vrModuleName
    Set vrModule = Modules(vrModuleName)

    ' 遍历模块内所有过程
    vrProcName = vrModule.ProcOfLine(1, vrProcType)
    Do While vrProcName <> ""
        ' 获取过程的起始行和总行数
        vrStartLine = vrModule.ProcStartLine(vrProcName, vrProcType)
        vrLineCount = vrModule.ProcCountLines(vrProcName, vrProcType)
        ' 提取完整代码
        vrFullCode = vrModule.Lines(vrStartLine, vrLineCount)

        ' 存入数据表
        With vrRs1
            .AddNew
            !ModuleName = vrModuleName
            !ProcedureCall = vrModule.Lines(vrStartLine, 1) ' 保留原定义行
            !ProcedureTxt = vrFullCode ' 写入完整代码
            .Update
        End With

        ' 跳到下一个过程起始行，避免重复遍历
        vrStartLine = vrStartLine + vrLineCount
        If vrStartLine > vrModule.CountOfLines Then Exit Do
        vrProcName = vrModule.ProcOfLine(vrStartLine, vrProcType)
    Loop

    DoCmd.Close acModule, vrModuleName

End Function

修改说明 #

1. 修复原代码中Idx未初始化的问题，避免逻辑异常
2. 去掉调用函数时的多余括号，防止参数被强制转为Variant类型
3. 用ProcOfLine、ProcStartLine、ProcCountLines替代逐行扫描，彻底解决注释误判、多行定义等问题，精准定位过程范围
4. 完善ProcedureTxt字段赋值，将完整过程代码存入数据表

内容的提问来源于stack exchange，提问作者Nata