如何获取Excel工作簿中定义的宏

我已经很久没有做过vba for Excel了,但是如果我记得清楚的话,代码的对象模型就不能通过脚本来访问了。

当您尝试访问它时,会收到以下错误。

Run-time error '1004':
Programmatic access to Visual Basic Project is not trusted

尝试:

Tools | Macro | Security |Trusted Publisher Tab
[x] Trust access to Visual Basic Project

现在您可以访问vb a ide了,您可以导出模块并在其中进行文本搜索,使用vb a/c,使用正则表达式查找子声明和函数声明,然后删除导出的模块。

我不确定是否有其他方法可以做到这一点,但这应该是可行的。

您可以查看以下链接,开始导出模块。 http://www.developersdex.com/vb/message.asp?p=2677&ID=%3C4FCD0AE9-5DCB-4A96-8B3C-F19C63CD3635%40microsoft.com%3E

在这里,我获得了有关允许Thrusted访问VB IDE的信息。

基于Martin的答案,在信任对vbp的访问之后,可以使用这组代码获取Excel工作簿的vb项目中所有公共子例程的数组。您可以将其修改为只包含subs、funcs、private或public…

Private Sub TryGetArrayOfDecs()
    Dim Decs() As String
    DumpProcedureDecsToArray Decs
End Sub

Public Function DumpProcedureDecsToArray(ByRef Result() As String, Optional InDoc As Excel.Workbook) As Boolean
    Dim VBProj As Object
    Dim VBComp As Object
    Dim VBMod As Object

    If InDoc Is Nothing Then Set InDoc = ThisWorkbook

    ReDim Result(1 To 1500, 1 To 4)
   DumpProcedureDecsToArray = True
    On Error GoTo PROC_ERR

    Set VBProj = InDoc.VBProject
    Dim FuncNum As Long
    Dim FuncDec As String
    For Each VBComp In VBProj.vbcomponents
        Set VBMod = VBComp.CodeModule
        For i = 1 To VBMod.countoflines
            If IsSubroutineDeclaration(VBMod.Lines(i, 1)) Then
                FuncDec = RemoveBlanksAndDecsFromSubDec(RemoveAsVariant(VBMod.Lines(i, 1)))
                If LCase(Left(VBMod.Lines(i, 1), Len("private"))) <> "private" Then
                    FuncNum = FuncNum + 1
                    Result(FuncNum, 1) = FindToLeftOfString(InDoc.Name, ".")    '
                    Result(FuncNum, 2) = VBMod.Name
                    Result(FuncNum, 3) = GetSubName(FuncDec)
                    Result(FuncNum, 4) = VBProj.Name
                End If
            End If
        Next i
    Next VBComp
 PROC_END:
    Exit Function
 PROC_ERR:
    GoTo PROC_END
End Function

Private Function RemoveCharFromLeftOfString(TheString As String, RemoveChar As String) As String
    Dim Result As String
    Result = TheString
    While LCase(Left(Result, Len(RemoveChar))) = LCase(RemoveChar)
        Result = Right(Result, Len(Result) - Len(RemoveChar))
    Wend
    RemoveCharFromLeftOfString = Result
End Function

Private Function RemoveBlanksAndDecsFromSubDec(TheLine As String) As String
    Dim Result As String
    Result = TheLine
    Result = RemoveCharFromLeftOfString(Result, " ")
    Result = RemoveCharFromLeftOfString(Result, "   ")
    Result = RemoveCharFromLeftOfString(Result, "Public ")
    Result = RemoveCharFromLeftOfString(Result, "Private ")
    Result = RemoveCharFromLeftOfString(Result, " ")
    RemoveBlanksAndDecsFromSubDec = Result
End Function

Private Function RemoveAsVariant(TheLine As String) As String
    Dim Result As String
    Result = TheLine
    Result = Replace(Result, "As Variant", "")
    Result = Replace(Result, "As String", "")
    Result = Replace(Result, "Function", "")
    If InStr(1, Result, "( ") = 0 Then
        Result = Replace(Result, "(", "( ")
    End If
    RemoveAsVariant = Result
End Function

Private Function IsSubroutineDeclaration(TheLine As String) As Boolean
    If LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("Function "))) = "function " Or LCase(Left(RemoveBlanksAndDecsFromSubDec(TheLine), Len("sub "))) = "sub " Then
        IsSubroutineDeclaration = True
    End If
End Function

Private Function GetSubName(DecLine As String) As String
    GetSubName = FindToRightOfString(FindToLeftOfString(DecLine, "("), " ")
End Function

Function FindToLeftOfString(FullString As String, ToFind As String) As String
    If FullString = "" Then Exit Function
    Dim Result As String, ToFindPos As Integer
    ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
    If ToFindPos > 0 Then
        Result = Left(FullString, ToFindPos - 1)
    Else
        Result = FullString
    End If
    FindToLeftOfString = Result
End Function

Function FindToRightOfString(FullString As String, ToFind As String) As String
    If FullString = "" Then Exit Function
    Dim Result As String, ToFindPos As Integer
    ToFindPos = InStr(1, FullString, ToFind, vbTextCompare)
    Result = Right(FullString, Len(FullString) - ToFindPos + 1 - Len(ToFind))
    If ToFindPos > 0 Then
        FindToRightOfString = Result
    Else
        FindToRightOfString = FullString
    End If
End Function