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

1
投票

我已经很长时间没有为 Excel 做过 vba 了，但如果我没记错的话，代码的对象模型无法通过脚本访问。

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

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 IDE，您可以导出模块并在其中进行文本搜索，使用 vba / c#，使用正则表达式查找子和函数声明，然后删除导出的模块。

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

您可以查看以下链接，开始导出模块。

http://www.developersdex.com/vb/message.asp?p=2677&ID=%3C4FCD0AE9-5DCB-4A96-8B3C-F19C63CD3635%40microsoft.com%3E

这是我获得有关提供对 VB IDE 的强制访问权限的信息的地方。

1
投票

基于 Martin 的答案，在您信任对 VBP 的访问之后，您可以使用这组代码来获取 Excel 工作簿的 VB 项目中所有公共子例程的数组。您可以将其修改为仅包含 subs、仅包含 func、仅包含 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

0
投票

该代码是在书中创建新工作表并打印表格，其中包含有关所有书籍的宏名称的列、运行宏的链接、在 ide 中打开宏的链接、相应模块的名称，并按模块和名称对表进行排序（如果工作表已存在）并且可见，则隐藏它，如果不可见，则添加使其可见并打印上述所有内容：

Sub ListMacrosWithSortedLinks()
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim rowNum As Long
    Dim macroName As String
    Dim moduleComp As Object
    Dim lineText As String
    Dim btn As Button
    
    ' Set the workbook
    Set wb = ThisWorkbook
    
    ' Add "MACROS" sheet if it doesn't exist
    On Error Resume Next
    Set ws = wb.Sheets("MACROS")
    On Error GoTo 0
    If ws Is Nothing Then
        Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        ws.name = "MACROS"
    End If
    
    ' Hide "MACROS" sheet if it was visible
    If ws.Visible = xlSheetVisible Then
        ws.Visible = xlSheetVeryHidden
        Exit Sub
    End If
    
    ' Make "MACROS" sheet visible if not visible
    If ws.Visible = xlSheetHidden Or ws.Visible = xlSheetVeryHidden Then
        ws.Visible = xlSheetVisible
        ws.Select ' Select the sheet
    End If
    
    ' Clear previous data and buttons in columns A, B, C, and D
    ws.Cells.ClearContents
    ws.Buttons.Delete
    
    ' Write headers and make them bold
    With ws.Range("A1:D1")
        .Value = Array("Macro Name", "Run Macro", "Open VBA IDE", "Module Name")
        .Font.Bold = True
    End With
    
    ' Initialize row number for writing
    rowNum = 2
    
    ' Loop through all modules in the workbook
    For Each moduleComp In wb.VBProject.VBComponents
        If moduleComp.Type = 1 Then ' Check if it's a module
            For i = 1 To moduleComp.codeModule.CountOfLines
                lineText = moduleComp.codeModule.Lines(i, 1)
                If InStr(1, lineText, "Sub ") = 1 Or InStr(1, lineText, "Private Sub ") = 1 Then
                    macroName = Trim(Mid(lineText, InStr(1, lineText, "Sub ") + 4))
                    macroName = Left(macroName, InStr(1, macroName, "(") - 1)
                    
                    ' Apply formatting to the cell before adding the hyperlink
                    ws.Cells(rowNum, 2).Font.color = RGB(192, 192, 192) ' Silver color
                    
                    ' Create a hyperlink-styled link to run the macro
                    ws.Hyperlinks.Add Anchor:=ws.Cells(rowNum, 2), _
                        Address:="", SubAddress:=moduleComp.name & "." & macroName, _
                        TextToDisplay:="Run Macro"
                    
                    ' Create a hyperlink to open VBA IDE
                    ws.Hyperlinks.Add Anchor:=ws.Cells(rowNum, 3), _
                        Address:="", SubAddress:=moduleComp.name & "." & macroName, _
                        TextToDisplay:="Open VBA IDE"
                    
                    ' Write macro information to worksheet
                    ws.Cells(rowNum, 1).Value = macroName
                    ws.Cells(rowNum, 4).Value = moduleComp.name
                    
                    ' Increment the row number
                    rowNum = rowNum + 1
                End If
            Next i
        End If
    Next moduleComp
    
    ' Sort the data by Module Name (col4) ascending, then by Macro Name (col1)
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=ws.Range("D2:D" & rowNum - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ws.Sort.SortFields.Add Key:=ws.Range("A2:A" & rowNum - 1), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange ws.Range("A1:D" & rowNum - 1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
End Sub

问题描述投票：0回答：3

3个回答

最新问题

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

问题描述 投票：0回答：3

3个回答

最新问题

问题描述投票：0回答：3