显示MacroOptions

Question

在Excel / VBA中，可以使用MacroOptions函数定义与宏或函数相关的一些信息。一旦通过VBA输入，是否可以访问此类信息？谢谢

Answer 1

我一直在寻找，但我发现没什么了不起。

我找到的唯一解决方法是使用Chip Pearson构建的代码并在his website上进行描述。

使用此代码，您可以获得有关过程的一般信息。

Public Enum ProcScope
    ScopePrivate = 1
    ScopePublic = 2
    ScopeFriend = 3
    ScopeDefault = 4
End Enum

Public Enum LineSplits
    LineSplitRemove = 0
    LineSplitKeep = 1
    LineSplitConvert = 2
End Enum

Public Type ProcInfo
    ProcName As String
    ProcKind As VBIDE.vbext_ProcKind
    ProcStartLine As Long
    ProcBodyLine As Long
    ProcCountLines As Long
    ProcScope As ProcScope
    ProcDeclaration As String
End Type

Function ProcedureInfo(ProcName As String, ProcKind As VBIDE.vbext_ProcKind, _
    CodeMod As VBIDE.CodeModule) As ProcInfo

    Dim PInfo As ProcInfo
    Dim BodyLine As Long
    Dim Declaration As String
    Dim FirstLine As String


    BodyLine = CodeMod.ProcStartLine(ProcName, ProcKind)
    If BodyLine > 0 Then
        With CodeMod
            PInfo.ProcName = ProcName
            PInfo.ProcKind = ProcKind
            PInfo.ProcBodyLine = .ProcBodyLine(ProcName, ProcKind)
            PInfo.ProcCountLines = .ProcCountLines(ProcName, ProcKind)
            PInfo.ProcStartLine = .ProcStartLine(ProcName, ProcKind)

            FirstLine = .Lines(PInfo.ProcBodyLine, 1)
            If StrComp(Left(FirstLine, Len("Public")), "Public", vbBinaryCompare) = 0 Then
                PInfo.ProcScope = ScopePublic
            ElseIf StrComp(Left(FirstLine, Len("Private")), "Private", vbBinaryCompare) = 0 Then
                PInfo.ProcScope = ScopePrivate
            ElseIf StrComp(Left(FirstLine, Len("Friend")), "Friend", vbBinaryCompare) = 0 Then
                PInfo.ProcScope = ScopeFriend
            Else
                PInfo.ProcScope = ScopeDefault
            End If
            PInfo.ProcDeclaration = GetProcedureDeclaration(CodeMod, ProcName, ProcKind, LineSplitKeep)
        End With
    End If

    ProcedureInfo = PInfo

End Function


Public Function GetProcedureDeclaration(CodeMod As VBIDE.CodeModule, _
    ProcName As String, ProcKind As VBIDE.vbext_ProcKind, _
    Optional LineSplitBehavior As LineSplits = LineSplitRemove)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' GetProcedureDeclaration
' This return the procedure declaration of ProcName in CodeMod. The LineSplitBehavior
' determines what to do with procedure declaration that span more than one line using
' the "_" line continuation character. If LineSplitBehavior is LineSplitRemove, the
' entire procedure declaration is converted to a single line of text. If
' LineSplitBehavior is LineSplitKeep the "_" characters are retained and the
' declaration is split with vbNewLine into multiple lines. If LineSplitBehavior is
' LineSplitConvert, the "_" characters are removed and replaced with vbNewLine.
' The function returns vbNullString if the procedure could not be found.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim LineNum As Long
    Dim S As String
    Dim Declaration As String

    On Error Resume Next
    LineNum = CodeMod.ProcBodyLine(ProcName, ProcKind)
    If Err.Number <> 0 Then
        Exit Function
    End If
    S = CodeMod.Lines(LineNum, 1)
    Do While Right(S, 1) = "_"
        Select Case True
            Case LineSplitBehavior = LineSplitConvert
                S = Left(S, Len(S) - 1) & vbNewLine
            Case LineSplitBehavior = LineSplitKeep
                S = S & vbNewLine
            Case LineSplitBehavior = LineSplitRemove
                S = Left(S, Len(S) - 1) & " "
        End Select
        Declaration = Declaration & S
        LineNum = LineNum + 1
        S = CodeMod.Lines(LineNum, 1)
    Loop
    Declaration = SingleSpace(Declaration & S)
    GetProcedureDeclaration = Declaration


End Function

Private Function SingleSpace(ByVal Text As String) As String
    Dim Pos As String
    Pos = InStr(1, Text, Space(2), vbBinaryCompare)
    Do Until Pos = 0
        Text = Replace(Text, Space(2), Space(1))
        Pos = InStr(1, Text, Space(2), vbBinaryCompare)
    Loop
    SingleSpace = Text
End Function

您可以使用以下代码调用ProcedureInfo函数：

Sub ShowProcedureInfo()
    Dim VBProj As VBIDE.VBProject
    Dim VBComp As VBIDE.VBComponent
    Dim CodeMod As VBIDE.CodeModule
    Dim CompName As String
    Dim ProcName As String
    Dim ProcKind As VBIDE.vbext_ProcKind
    Dim PInfo As ProcInfo

    CompName = "modVBECode"
    ProcName = "ProcedureInfo"
    ProcKind = vbext_pk_Proc

    Set VBProj = ActiveWorkbook.VBProject
    Set VBComp = VBProj.VBComponents(CompName)
    Set CodeMod = VBComp.CodeModule

    PInfo = ProcedureInfo(ProcName, ProcKind, CodeMod)

    Debug.Print "ProcName: " & PInfo.ProcName
    Debug.Print "ProcKind: " & CStr(PInfo.ProcKind)
    Debug.Print "ProcStartLine: " & CStr(PInfo.ProcStartLine)
    Debug.Print "ProcBodyLine: " & CStr(PInfo.ProcBodyLine)
    Debug.Print "ProcCountLines: " & CStr(PInfo.ProcCountLines)
    Debug.Print "ProcScope: " & CStr(PInfo.ProcScope)
    Debug.Print "ProcDeclaration: " & PInfo.ProcDeclaration
End Sub