none
Aktive Datenbank im VBE und Auflistung der Argumente einer Prozedur RRS feed

  • Frage

  • Hallo

    Ich möchte eine Auflistung von Prozeduren und Argumenten einer Datenbank. Als Beispiel 
    Public Function fctTest(ByVal strTest as string, Optional ByRef bytTest as Byte = 55) as Boolean
    if strTest = "a" and bytTest = 55 then
    fctTest=True
    End if
    End Function

    Ich möchte die ganze Funktion (Von Public bis End Function)
    Ausserdem möchte ich den Prozedurnamen und alle Argumente aufgelistet haben. Also
    Public / Function / fctTest / Boolean
    ByVal / strTest / String
    Optional / ByRef / bytTest / Byte / 55

    Das ganze soll schlussentlich als AddIn erstellt werden.

    Ich habe meine Wünsche eigentlich alle schon programmiert. Aber trotzdem habe ich noch Fragen:

    Frage 1: Ich verstehe noch nicht ganz die Verwendung von VBE.ActiveVBProject. Ich speichere es als AddIn. Jetzt öffne ich Datenbank A und möchte das AddIn ausführen, dass mir dann die Prozeduren aus DB A auflisten soll. Ist das in 'Property Get getCheckVBIDE()' richtig eingegeben, dass er dann DB A nimmt? Auch wenn im Projekt Explorer ev. noch andere Datenbanken offen sind (z.B. weitere AddIns)?

    Frage 2: Die Prozedur ShowProcedureInfo listet (ohne Argument 'strProcName') die gewünschten Daten aller vorhandenen Prozeduren auf. Das funktioniert in meinem Test auch. Wenn ich aber nur eine Prozedur aufgelistet haben möchte, kann ich im Argument 'strProcName' den Namen übergeben. Manchmal funktioniert es, häufiger aber nicht. Wenn es nicht funktioniert, dann stoppt die Verarbeitung in Prozedur 'ProcedureInfo' in der ersten Codezeile (Bodyline...) mit dem 'Run-time error '35': Sub or Function not defined'. Woran kann das liegen?

    Und zum Schluss: Ich habe keinen Code gefunden, der mir die Argumente der Prozedur auflistet (siehe oben: Public, ByVal, String etc). Deshalb habe ich mir das selbst gebastelt (siehe Function fctExtractParameter). Bei meinen Tests funktionier das auch. Es wäre toll, wenn sich das jemand anschauen und/oder testen könnte, ob das so funktionieren kann oder ob ich etwas vergessen habe (insbesondere in der Sektion ' Search for special character and remove it). Für Tipps bin ich immer dankbar

    Ich hoffe ich konnte meine Anliegen verständlich erklären. Hier also der Code. Ich schicken den ganzen, damit sicher alles funktioniert. Betreffend meinen Fragen sind aber eigentlich nur die Prozeduren getCheckVBIDE, fctExtractParameter und ShowProcedureInfo wichtig.

    Schon mal vielen Dank vorab. 

    Option Compare Database
    Option Explicit
    
    ' Many of the code is from http://www.cpearson.com/excel/vbe.aspx. Thank you for providing
    
    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 String
        ProcStartLine As Long
        ProcBodyLine As Long
        ProcCountLines As Long
        ProcScope As ProcScope
        ProcDeclaration As String
        ProcCode As String
    End Type
    
    
    Dim VBIDEActiveProject As VBIDE.VBProject
    
    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.ProcBodyLine = .ProcBodyLine(ProcName, ProcKind)
                PInfo.ProcCountLines = .ProcCountLines(ProcName, ProcKind)
                PInfo.ProcStartLine = .ProcStartLine(ProcName, ProcKind)
                PInfo.ProcCode = .Lines(.ProcStartLine(ProcName, ProcKind), .ProcCountLines(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
    
        PInfo.ProcKind = ProcKindString(ProcKind, PInfo.ProcDeclaration)
    
        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
    Public Function fctCheckVBIDE() As Boolean    '(Optional CheckVBIDE As VBIDE.VBProject = Nothing) As Boolean
        Dim g As VBIDE.VBProject
    
        Set g = getCheckVBIDE
        If getCheckVBIDE.Protection = vbext_pp_locked Then
            fctCheckVBIDE = False
            Exit Function
        End If
        fctCheckVBIDE = True
    End Function
    Public Property Get getCheckVBIDE() As VBIDE.VBProject
    
        If VBIDEActiveProject Is Nothing Then
            Set VBIDEActiveProject = VBE.ActiveVBProject
        Else
            Set getCheckVBIDE = VBIDEActiveProject
        End If
    
    End Property
    ' ----------------------------------------------------------------
    ' Procedure Name: ProcKindString
    ' Purpose: Converts vbExt-text to less uncrypt text
    ' Procedure Kind: Function
    ' Procedure Access: Public
    ' Parameter ProcKind (vbext_ProcKind): The vbExt-Text
    ' Parameter strProcDeclaration (String): First row of the Code to to return Sub of Function when vvbExt is vbext_pk_Proc
    ' Return Type: String
    ' Author: uwth
    ' Date: 05.05.2020
    ' ----------------------------------------------------------------
    Function ProcKindString(ProcKind As VBIDE.vbext_ProcKind, strProcDeclaration As String) As String
        Select Case ProcKind
        Case vbext_pk_Get
            ProcKindString = "Property Get"
        Case vbext_pk_Let
            ProcKindString = "Property Let"
        Case vbext_pk_Set
            ProcKindString = "Property Set"
        Case vbext_pk_Proc
            If InStr(1, strProcDeclaration, "Sub", vbTextCompare) Then
                ProcKindString = "Sub"
            ElseIf InStr(1, strProcDeclaration, "Function", vbTextCompare) Then
                ProcKindString = "Function"
            End If
        Case Else
            ProcKindString = "Unknown Type: " & CStr(ProcKind)
        End Select
    End Function
    Function fctComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String
        Select Case ComponentType
        Case vbext_ct_ActiveXDesigner
            fctComponentTypeToString = "ActiveX Designer"
        Case vbext_ct_ClassModule
            fctComponentTypeToString = "Class Module"
        Case vbext_ct_Document
            fctComponentTypeToString = "Document Module"
        Case vbext_ct_MSForm
            fctComponentTypeToString = "UserForm"
        Case vbext_ct_StdModule
            fctComponentTypeToString = "Code Module"
        Case Else
            fctComponentTypeToString = "Unknown Type: " & CStr(ComponentType)
        End Select
    End Function
    Sub ShowProcedureInfo(Optional strProcName As String)
    ' Without any strProcName the procedure runs trough all module and Debug.Prints some information about each procedure
        Dim ProcName As String
        Dim ProcKind As VBIDE.vbext_ProcKind
        Dim PInfo As ProcInfo
    
        If fctCheckVBIDE Then
    
            'Set VBIDEActiveProject = getCheckVBIDE
    
            Dim objVBComponent As VBComponent
            Dim lngLine As Long
            Dim strProcedurName As String, strTempProcedurName As String
    
            For Each objVBComponent In getCheckVBIDE.VBComponents
    
                With objVBComponent.CodeModule
                    For lngLine = 1 To .CountOfLines
                        If .ProcOfLine(lngLine, ProcKind) <> "" Then
                            strProcedurName = .ProcOfLine(lngLine, ProcKind)
                            If strProcedurName <> strTempProcedurName Then
    
                                'ToDo: Der Code funktioniert mit den vor- und nachfolgenden als Kommentar markierte Zeilen. Dies mus angeschaut werden.
                                If Len(strProcName) > 0 Then
                                    ProcName = strProcName
                                Else
                                    ProcName = strProcedurName
                                End If
                                ProcKind = ProcKind
    
                                PInfo = ProcedureInfo(ProcName, ProcKind, objVBComponent.CodeModule)
    
                                Debug.Print
                                Debug.Print "ModulName: " & objVBComponent.Name
                                Debug.Print "ModulType: " & fctComponentTypeToString(objVBComponent.Type)
                                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
                                Debug.Print "ProcCode: "
                                Debug.Print PInfo.ProcCode
                                fctExtractParameter PInfo.ProcDeclaration
    
                                DoEvents
    
                                If Len(strProcName) > 0 Then GoTo Exit_ShowProcedureInfo
    
                                strTempProcedurName = strProcedurName
                            End If
                        End If
                    Next
                End With
            Next
        End If
    Exit_ShowProcedureInfo:
    End Sub
    Function fctExtractParameter(ByVal strParameter As String)  ' The whole first Line of the procedure
    ' e.g. Function fctComponentTypeToString(ComponentType As VBIDE.vbext_ComponentType) As String"
    
    '    Dim strParameter As String        ' The Parameter: Text between () of a Procedure (or a part of it)
        Dim bytStartParameter As Byte     ' The position of the '(' in a procedure
        Dim bytEndParameter As Byte       ' The position of the ')' in a procedure
        Dim bytLoopCounter As Byte        ' Counter of how many characters needs to be cut off
        Dim bytCounterParameters As Byte  ' Counts the amount of parameters
    
        Dim strSuffix As String     ' Text after the )
        Dim bytSuffixEnd As Byte    ' Number of characters after )
    
        Dim bytSuffixREM As Byte    ' Remarks after the ), marked as Rem, if there are any
        Dim bytSuffixRemarks As Byte    ' Remarks after the ), marked as ', if there are any
    
        Dim bolNoSpecialCharacter As Boolean    ' Check until no special character is found
    
        bytStartParameter = InStr(1, strParameter, "(", vbTextCompare)  ' First ( in the Code
        bytEndParameter = InStr(1, strParameter, ")", vbTextCompare)    ' First ) in the Code
    
    ' === Test if there are Remarks at the end of the line start ===
        bytSuffixRemarks = InStr(bytEndParameter + 1, strParameter, "'", vbTextCompare)     ' Searching for Remarks ' after the )
        bytSuffixREM = InStr(bytEndParameter + 1, strParameter, "Rem", vbTextCompare)       ' Searching for Remarks REM after the )
    
        If bytSuffixRemarks >= bytSuffixREM Then
            bytSuffixEnd = bytSuffixRemarks
        Else
            bytSuffixEnd = bytSuffixREM
        End If
        ' === Test if there are Remarks at the end of the line End ===
    
        ' Check and cut off if there is a comment after )
        If Len(strParameter) = bytEndParameter Then
            strSuffix = ""
        Else
            If bytSuffixEnd = 0 Then
                strSuffix = Trim$(Mid$(strParameter, bytEndParameter + 1, Len(strParameter) - bytEndParameter))
            Else
                strSuffix = Trim$(Mid$(strParameter, bytEndParameter + 1, Len(strParameter) - bytEndParameter - 1 - (Len(strParameter) - bytSuffixEnd)))
            End If
        End If
    
        If Len(strSuffix) < 1 Then
            Debug.Print "No Suffix Modul"
        Else
            If Left$(strSuffix, 2) = "AS" Then
                bytLoopCounter = 1
                Debug.Print "Suffix Modul: " & fctExtractDetail(Trim$(Right$(strSuffix, Len(strSuffix) - 2)), bytLoopCounter)
            End If
        End If
    
        strParameter = Trim$(Mid$(strParameter, bytStartParameter + 1, bytEndParameter - bytStartParameter - 1))   'Only the Text betwenn (...) or lenght 0
    
        Debug.Print "Parameters: " & strParameter
    
        Do
            strParameter = Trim$(strParameter)
            If Len(strParameter) > 1 Then   ' Check if Parameter  is available
    
                Do
                    ' Search for special character and remove it. Can have more than one at a time
                    bolNoSpecialCharacter = True
    
                    If Left$(Trim$(strParameter), 1) = "," _
                       Or Left$(Trim$(strParameter), 1) = "_" _
                       Or Left$(Trim$(strParameter), 1) = Chr(13) _
                       Or Left$(Trim$(strParameter), 1) = Chr(10) Then
                        bolNoSpecialCharacter = False
                    End If
    
                    If Not bolNoSpecialCharacter Then strParameter = Trim$(Right$(strParameter, Len(strParameter) - 1))
    
                Loop Until bolNoSpecialCharacter
    
                bytCounterParameters = bytCounterParameters + 1
    
                ' Check for and extract 'Optional'
                Select Case Left(strParameter, 8)
                Case "Optional"
                    Debug.Print "Präfix " & bytCounterParameters & ": " & Left(strParameter, 8)
                    bytLoopCounter = 8
                    strParameter = Trim$(Mid$(strParameter, bytLoopCounter + 1))
                End Select
    
                ' Check for and extract 'ByRef' and 'ByVal'
                Select Case Left(strParameter, 5)
                Case "ByRef", "ByVal"
                    Debug.Print "Präfix " & bytCounterParameters & ": " & Left(strParameter, 5)
                    bytLoopCounter = 5
                    strParameter = Trim$(Mid$(strParameter, bytLoopCounter + 1))
                End Select
    
                ' Extract Name of Parameter
                bytLoopCounter = 1
                Debug.Print "Parameter " & bytCounterParameters & ": " & fctExtractDetail(strParameter, bytLoopCounter)
                strParameter = Trim$(Mid$(strParameter, bytLoopCounter))
    
                ' Check for and extract Type of Parameter
                If Left$(strParameter, 2) = "AS" Then
                    bytLoopCounter = 1
                    Debug.Print "As Parameter " & bytCounterParameters & ": " & fctExtractDetail(Trim$(Right$(strParameter, Len(strParameter) - 2)), bytLoopCounter)
                    If Len(strParameter) > 1 Then
                        strParameter = Trim$(Right$(strParameter, Len(strParameter) - bytLoopCounter - 2))
                    Else
                        Exit Do
                    End If
                End If
    
                ' Check for and extract optional Standard value
                If Left(strParameter, 1) = "=" Then
                    bytLoopCounter = 1
                    Debug.Print "Optinal standard value " & bytCounterParameters & ": " & fctExtractDetail(Trim$(Right$(strParameter, Len(strParameter) - 1)), bytLoopCounter)
                    If Len(strParameter) > 1 Then
                        strParameter = Trim$(Right$(strParameter, Len(strParameter) - bytLoopCounter - 1))
                    Else
                        Exit Do
                    End If
                End If
    
            Else
                If bytCounterParameters < 1 Then
                    Debug.Print "No Parameter"
                End If
                Exit Do
            End If
    
            If bytCounterParameters > 254 Then
                ' Emergency that the Code does not loop without exit
                Exit Do
            End If
            Stop
        Loop
    End Function
    
    Function fctExtractDetail(ByVal strFull As String, ByRef bytLoopCounter) As String
        Dim strMidParameter As String
    
        Do
            strMidParameter = Mid$(strFull, 1, bytLoopCounter)
    
            If bytLoopCounter > Len(strFull) Then Exit Do  ' Keine weiteren Argumente
            If Right$(strMidParameter, 1) = " " Or Right$(strMidParameter, 1) = "," Then
                strMidParameter = Mid$(strFull, 1, bytLoopCounter - 1)
                Exit Do
            End If
            bytLoopCounter = bytLoopCounter + 1
    
        Loop
        fctExtractDetail = Trim$(strMidParameter)
    
    End Function


    Danke und Gruss Thomas

    Mittwoch, 6. Mai 2020 15:38

Antworten

  • zu 1: VBE.ActiveVBProject siehe: ActiveVbProjekt

             Ich würde da auch eine Referenz auf die Anwendung erwarten.

    zu 2: .ProcOfLine(lngLine, ProcKind) - die Anweisung schränkt auf Prozeduren und Funktionen eine. Properties werden ignoriert. Ansonsten sollte es wohl funktionieren.

    Debuggen und händisch prüfen, wäre mein Ansatz.


    Markus


    Mittwoch, 24. Juni 2020 05:15