Viel Spass mit dem Modul PrintR

lib_printr.bas

Attribute VB_Name = "lib_printR"
'-------------------------------------------------------------------------------
'File         : lib_printR.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/print_r/index
'Environment  : VBA 2010 +  getestet mit MS Access 2010 & MS Excel 2010
'Version      : 2.17.1
'Name         : printR
'Author       : Stefan Erb (ERS)
'History      : 16.10.2013 - 1.0.0  - ERS -  Creation
'               ...
'               13.11.2018 - 2.13.1 - ERS - HotFix. Bei Objekt-Properties mit einem "As" im Namen gab es Probleme. RegExp-Pattern angepasst
'               24.09.2019 - 2.14.0 - ERS - Paramter prListSingleLine hinzugefügt
'               14.10.2019 - 2.15.0 - ERS - Bei Collection wird jetzt auch der Key mitgeliefert: https://stackoverflow.com/a/50063928
'                                         - Bei Indexnummerierungn in Listen ein # davor gesetzt, damit man weiss, dass es ien Index ist
'               15.10.2019 - 2.16.0 - ERS - Neuer Alias print_l für Listenobjekte (ListStream, Iterator) hinzugefügt
'               07.02.2019 - 2.17.0 - ERS - Unicode für nicht druckbare Zeichen repariert: Sonderzeichen ausserhalb Ascii 32 bis 127 ersetzen. Leerzeichen nicht ersetzen. € Auch nicht ersetzen
'                                           Neu können auch Access-Klassen ausgewertet werden. Wenn der Argumetn prObjPropertiesAsList können die Properties ausgegeben werden
'               19.02.2020 - 2.17.1 - ERS - Fehler nach AccessObj gefixt. AccessObje die Listen sind werden wieder richtig angezeigt. zB Matches
'
'Einschränkungen:
'             Leider lassen UDT (User defined Types) sich nicht in ein Variant Parsen, da sie
'             als Late Binding gehandelt wird. Dadurch können keine UDT oder Arrays von UDT
'             übergeben werden. Dies wirft ein fehler
'             Ist der ODT in einem Objekt als Property oder in einem Dictionaray oder
'             einer Collection, wird der folgende Fehler in der Ausgabe ausgegen:
'             <Name_des_UDT> Error 440: Automation error
'-------------------------------------------------------------------------------
Option Explicit
'/**
' * Einstellungen für die Conditional Compilation in VBA.
' */
#Const debugmode = False    'Zu Debugzwecken das Errorhandling ausschalten
 
'-------------------------------------------------------------------------------
' Private Members
'-------------------------------------------------------------------------------
'https://stackoverflow.com/a/50063928
#If Win64 Then
    Public Declare PtrSafe Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongPtr)
#Else
    Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long)
#End If
 
'Pattern für den Index/Key eines Subelentes. Verfügbae Variablen: idx
Private Const C_KEY_PATTERN = "[{$idx}] => "
'Pattern für die Typenbezeichnungen. Verfügbare Variablen: typeName
Private Const C_TYPE_PATTERN = "<{$typeName}>"
'Pattern für die Typenbezeichnung bei Klassenmodulen. Verfügbare Variablen: typeName, className
Private Const C_CLASSMODUL_TYPE_PATTERN = "{$typeName}::{$className}"
'Für DAO.Recordset. Wieviele Zeilen maximal ausgegeben werden
Private Const C_RS_MAX_ROWS = 5
 
'Typennamen aus TypeName()
Private Const C_TYPE_ERROBJECT = "ErrObject"                  'ErrObject
Private Const C_TYPE_COLLECTION = "Collection"                'Collection
Private Const C_TYPE_DICTIONARY = "Dictionary"                'Dictionary
Private Const C_TYPE_property = "Property"                    'Property
Private Const C_TYPE_PROPERTIES = "Properties"                'Properties
Private Const C_TYPE_IREGEXP2 = "IRegExp2"                    'IRegExp2
Private Const C_TYPE_IMATCH2 = "IMatch2"                      'IMatch2
Private Const C_TYPE_ADODB_RECORDSET = "Recordset"            'ADODB Recordset
Private Const C_TYPE_DAO_RECORDSET = "Recordset2"             'DAO Recordset
Private Const C_TYPE_ITERATOR = "Iterator"                    'Iterator
Private Const C_TYPE_FIELD2 = "Field2"                        'Field2
Private Const C_TYPE_FOLDER = "Folder"                        'Folder
Private Const C_TYPE_FILE = "File"                            'File
 
 
'-------------------------------------------------------------------------------
' Public Members
'-------------------------------------------------------------------------------
'/**
' * Die Auswahl an Möglichkeiten zur Ausgabe
' */
Public Enum enuPrintROutputMethode
    prConsole = 2 ^ 0       'Direktfenster
    prReturn = 2 ^ 1        'Als Rückgabewert
    prClipboard = 2 ^ 2     'In den Zwieschenspeicher des PCs
    prMsgBox = 2 ^ 3        'Als MassegeBox asugeben
End Enum
 
'/**
' * Weitere Steuerungen
' */
Public Enum enuPrintRParams
    prNoParams = 0                      'Kein Parameter hat Gültigkeit
    prShowType = 2 ^ 0                  'Zeigt den Datentype am Anfangan in <> an
    prStringSingleQuotes = 2 ^ 1        'Setzt Strings in einfache Anführungszeichen. Hat vor prStringDoubleQuotes vorrang.
    prStringDoubleQuotes = 2 ^ 2        'Setzt Strings in doppetle Anführungszeichen
    prEscapeDoubleQuotes = 2 ^ 3        'Setzt wandelt " innerhalb eines Textes zu "". Somit ist der String direkt weiterverwendbar
    prEscapeSpaces = 2 ^ 4              'Tab, Cr, Lf als /t, /r, /n zurückgeben, falls nicht gesetzt, werden die meisten mit prEscapeNotPrintableChars ersetzt
    prEscapeNotPrintableChars = 2 ^ 5   'Nicht Druckbare Zeichen als Unicode ausgeben: Sonderzeichen ausserhalb Ascii 32 bis 127 ersetzen. Leerzeichen nicht ersetzen. € Auch nicht ersetzen
    prSql = 2 ^ 6                       'Die Werte als SQL-Text
    prListSingleLine = 2 ^ 7                'Auch lIsten in einer Zeile anzeigen (Array, Dictionary, Collection
    prObjPropertiesAsList = 2 ^ 8
    'Default: Typ Anzeigen + Stringbegrenzung ' + Leerzeichen als \t etc. + nicht druckbare Zeichen als Unicode
    prParamsDefault = prShowType + prStringSingleQuotes + prEscapeSpaces + prEscapeNotPrintableChars
End Enum
 
'-------------------------------------------------------------------------------
' Public Methodes
'-------------------------------------------------------------------------------
 
'/**
' * Ausgabe des Variable. Ersetzt debug.print für vereinzelte Werte
' * Verwendete Funktion pushArray(): wiki.yaslaw.info/dokuwiki/doku.php/vbvbaarrayfunctions#pusharray
' * @param  Variant     Zu prüfende Variable
' * @param  enuPrintRParams
' *                     Diverse Parameter zur Formatierung der Ausgabe. Die verschiedenen Parameter lassen sich kombinieren.
' *                     Es gibt Parameters, die in Kombination keinen Sinn machen. zB: prStringSingleQuotes+prStringDoubleQuotes.
' *                     In diesem Fall wird der kleinere Wert genommen. Also nur prStringSingleQuotes.
' *                     Für die genaue Funktion der Parameter, siehe Kommentar beim Enum enuPrintRParams
' *                     Wenn man vom Standart einfach etwas weghabenwill, dann kann man das auch als Negativ-Parameter mitgeben
' * @param  enuPrintROutputMethode
' *                     Art der Rückgabe: Standart ist das Direktfenster. Alternativ kann man auch als Rückgabewert der
' *                     Funktion oder in den Zwieschnepseicher des PCs schreiben. Grad letzteres ist bei gösseren Verschachtelungen
' *                     Empfehlenswert, da das Direktfenser eine Beschränkte Anzahl Zeilen hat.
' *                     Die Auswahlen lassen sich auch kombinieren: prConsole+prClipboard
' * @return Variant     Nichts oder die Analyse als String
' * @TODO   Einige Dinge weren noch nicht so ausgegeben wie ich das will. Sobald ich weiss wie ich das machen kann, wird das erweiter
' *         - UserDefinedTypes
' *         - ggf. Range von Excel
' */
Public Function print_r( _
        ByRef iExpression As Variant, _
        Optional ByVal iParams As enuPrintRParams = prParamsDefault, _
        Optional ByVal iReturn As enuPrintROutputMethode = prConsole _
) As String
#If debugmode Then
On Error GoTo Err_Handler
#End If
    Dim rt As enuPrintRParams
    Dim retVal As String
 
    'Return-Tpe bestimmen. Wenn iParams negativ ist, diesen versuchen von prParamsDefault abzuziehen
    'iParams ist Negativ und Teil von prParamsDefault -> von prParamsDefault abziehen
    If iParams < 0 And (prParamsDefault And Abs(iParams)) Then
        rt = prParamsDefault + iParams
    'iParams ist negativ, aber nicht teil von prParamsDefault -> prParamsDefault verwenden
    ElseIf iParams < 0 Then
        rt = prParamsDefault
    'iParams ist positiv -> iParams weiter verwenden
    Else
        rt = iParams
    End If
 
    'Return-Value ermitteln
    retVal = print_r_priv(iExpression, , , rt)
 
 
Exit_Handler:
    On Error Resume Next
 
    'Ausgabe an ImmadiateWindow
    If andB(iReturn, prConsole) Then Debug.Print retVal
    'Wert zurückgeben
    If andB(iReturn, prReturn) Then print_r = retVal
    'Wert in die Zwieschenablage kopieren
    If andB(iReturn, prClipboard) Then toClipboard retVal
    'Wert als MsgBox ausgeben
    If andB(iReturn, prMsgBox) Then MsgBox retVal
 
    Exit Function
Err_Handler:
    retVal = "Error in print_f: [" & Err.Source & "] #" & Err.Number & " " & Err.Description
    Resume Exit_Handler
    Resume
End Function
 
'/**
' * Wie print_r mit den den Parametern prEscapeDoubleQuotes + prStringDoubleQuotes, sowieprReturn + prConsole
' * c für [C]ode
' * Eignet sich, wenn man das Resultat später weiterverwenden will
' * @example: c "a" & chr(34) & "b" -> "a""b"
' * @param  Variant     Zu prüfende Variable
' * @return Variant     Nichts oder die Analyse als String
Public Function c(ByRef iExpression As Variant) As String
    c = print_r(iExpression, prEscapeDoubleQuotes + prStringDoubleQuotes, prReturn + prConsole)
End Function
 
'/**
' * Alias zu print_r
' * d für [D]ebug
' * @params siehe print_r
' */
Public Function d( _
        ByRef iExpression As Variant, _
        Optional ByVal iParams As enuPrintRParams = prParamsDefault, _
        Optional ByVal iReturn As enuPrintROutputMethode = prConsole _
) As String
    d = print_r(iExpression, iParams, iReturn)
End Function
 
'/**
' * Alias zu print_r
' * Wendet bei meinen bekannten ListenObjekten den Print_r nur auf die Liste an, nicht auf das ganze Objekt
' * @params siehe print_r
' */
Public Function print_l(ByRef iExpression As Variant, _
        Optional ByVal iParams As enuPrintRParams = prParamsDefault, _
        Optional ByVal iReturn As enuPrintROutputMethode = prConsole _
) As String
    Select Case TypeName(iExpression)
        Case "ListStream":  print_l = print_r(iExpression.list, iParams, iReturn)
        Case "Iterator":    print_l = print_r(iExpression.Source, iParams, iReturn)
        Case "JSF":         print_l = print_r(iExpression.map, iParams, iReturn)
        Case Else:          print_l = print_r(iExpression, iParams, iReturn)
    End Select
End Function
 
'/**
' * Wendet ein print_r für die Console auf mehrere Elemente an
' * @param  Array<Variant>
' */
Public Sub print_rm(ParamArray iExpressions() As Variant)
    Dim v As Variant: For Each v In iExpressions
        print_r v, prConsole
    Next v
End Sub
 
'/**
' * Spezialfall zum einfach RegExp testen zu können
' * [D]ebug[R]eg[E]xp
' * @param  String      Pattern
' * @param  String      zu untersuchneder Text. Wenn Leer, dann wird der RegExp analysiert
' * @param  String      Replace. Wenn leer, dann wird der Exeute analysiert, ansonsten das Replaceergebnis
' * @param  enuPrintRParams
' * @param  enuPrintROutputMethode
' * @return Variant     Nichts oder die Analyse
' */
Public Function dRx( _
        ByVal iPattern As String, _
        Optional ByVal iText As String, _
        Optional ByVal iReplace As String, _
        Optional ByVal iParams As enuPrintRParams = prParamsDefault, _
        Optional ByVal iReturn As enuPrintROutputMethode = prConsole _
)
On Error GoTo Err_Handler
    Dim rx As Object:   Set rx = cRx(iPattern)
    If iText = Empty Then
        dRx = print_r(rx, iParams, iReturn)
    ElseIf iReplace = Empty Then
        dRx = print_r(rx.execute(iText), iParams, iReturn)
    Else
        dRx = print_r(rx.replace(iText, iReplace), iParams, iReturn)
    End If
    Exit Function
Err_Handler:
    Dim Msg As String
    Select Case Err.Number
        Case 5017:  Msg = "Invalid Pattern"
        Case Else:  Msg = Err.Description
    End Select
 
    If andB(iReturn, prConsole) Then Debug.Print Msg
    If andB(iReturn, prMsgBox) Then MsgBox Msg, vbCritical
    If andB(iReturn, prReturn) Then dRx = Msg
    If andB(iReturn, prClipboard) Then toClipboard Msg
End Function
 
'/**
' * Eine ganz einfache Form, die den Wert zurückgibt. Ist Praktisch um in einem SQL angewendet zu werden
' * @param  Variant     Zu prüfende Variable
' * @return Variant     die Analyse als String
' */
Public Function analyze(ByRef iExpression As Variant) As String
    analyze = print_r(iExpression, prParamsDefault, prReturn)
End Function
 
'-------------------------------------------------------------------------------
' Private Methodes
'-------------------------------------------------------------------------------
 
'/**
' * erstellt den Text. Diese Funktion hat mehr Parameter als print_r, da sie sich selber aufruft und die entsprechenden Params dazu braucht
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   fertiger pr-Text für das übergebene Objekt
' */
Private Function print_r_priv( _
        ByRef iExpression As Variant, _
        Optional ByVal iLevel As Integer = 0, _
        Optional ByVal idx As Variant = Null, _
        Optional ByVal iParams As enuPrintRParams = prParamsDefault, _
        Optional ByRef oValid As Boolean _
) As String
    Dim valid As Boolean
 
    'Jede Funktion hat die Validierung in sich drin. valid Beinhaltet die Information, ob die Methode angewandt wurde oder nicht
 
    '== Spezailfälle ==
    'Spezielle Listen
    If Not valid Then print_r_priv = prArray(iExpression, iLevel, idx, iParams, valid)              'Array
    If Not valid Then print_r_priv = prArrayMDim(iExpression, iLevel, idx, iParams, valid)          'ArrayMDim
    If Not valid Then print_r_priv = prCollection(iExpression, iLevel, idx, iParams, valid)         'Collection
    If Not valid Then print_r_priv = prDictionary(iExpression, iLevel, idx, iParams, valid)         'Dictionary
 
    'Spezielle Objekte
    If Not valid Then print_r_priv = prError(iExpression, iLevel, idx, iParams, valid)              'Error
    If Not valid Then print_r_priv = prRegExp(iExpression, iLevel, idx, iParams, valid)             'RegExp
    If Not valid Then print_r_priv = prMatch(iExpression, iLevel, idx, iParams, valid)              'Match
    If Not valid Then print_r_priv = prIterator(iExpression, iLevel, idx, iParams, valid)           'Iterator
    If Not valid Then print_r_priv = prRecordset(iExpression, iLevel, idx, iParams, valid)          'Recordset
    If Not valid Then print_r_priv = prDaoField2(iExpression, iLevel, idx, iParams, valid)          'DaoField2
    If Not valid Then print_r_priv = prFolder(iExpression, iLevel, idx, iParams, valid)             'Folder
    If Not valid Then print_r_priv = prFile(iExpression, iLevel, idx, iParams, valid)               'File
    If Not valid Then print_r_priv = prProperty(iExpression, iLevel, idx, iParams, valid)           'Property
    If Not valid Then print_r_priv = prProperties(iExpression, iLevel, idx, iParams, valid)         'Properties
    If Not valid Then print_r_priv = prAccessClass(iExpression, iLevel, idx, iParams, valid)        'AccessClass
    If Not valid Then print_r_priv = prClassModule(iExpression, iLevel, idx, iParams, valid)        'ClassModule
 
    '== Standart-Verfahren==
    'Listen mit item.Key=>item.Value:
    If Not valid Then print_r_priv = prGenericKeyList(iExpression, iLevel, idx, iParams, valid)
 
    'Listen mit Index und SubItems: Fields, SubMatches etc
    If Not valid Then print_r_priv = prGenericItemList(iExpression, iLevel, idx, iParams, valid)
    If Not valid Then print_r_priv = prGenericIndexList(iExpression, iLevel, idx, iParams, valid)
 
    'Alles was noch nicht behandelt wurde.
    If Not valid Then print_r_priv = prDefault(iExpression, iLevel, idx, iParams, valid)            'Default
    oValid = valid
End Function
 
'/**
' * Reportiert ein Error, welcher ausgelöst wird, wenn irgendwo eine Datenunverträglichkeit auftauchte
' * @param  Long        Fehlernummer
' * @param  String      Fehlertext
' * @param  String      Name des Datentypes des Objektes, welches untersucht wurde
' * @param  Integer     Aktueller Level der Verschachtelung
' * @param  Variant     Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @return String      Text der Verschachtelungs dieses Objektes
' */
Private Function print_error( _
        ByVal iErrNumber As Long, _
        ByVal iErrDesc As String, _
        ByVal iType As String, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant _
) As String
    Dim idxs As String: idxs = IIf(IsNull(idx), "", "[" & idx & "] => ")
    Dim pVar As String
    pVar = "Error" & IIf(iErrNumber <> 0, " " & iErrNumber, "") & ": " & iErrDesc
    print_error = String(iLevel, vbTab) & idxs & "<" & iType & ">" & " " & pVar
End Function
 
'/**
' * Formatiert eine Liste, inkl Header
' * @param  Array<String>   Liste der pr-Texte aller Childrens
' * @param  Variant     Das zu untersuchende Objekt
' * @param  Integer     Aktueller Level der Verschachtelung
' * @param  Variant     Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @return String      Verschachteulng & Typentext
' */
Private Function getList( _
        ByRef iRows() As String, _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams _
) As String
    getList = getVarRow(iExpression, iLevel, idx, iParams)
On Error GoTo emptyList
    If andB(iParams, prListSingleLine) Then
        If (UBound(iRows) - LBound(iRows) + 1) > 0 Then
            getList = getList & " (" & join(iRows, ", ") & ")"
        End If
    Else
        If (UBound(iRows) - LBound(iRows) + 1) > 0 Then
            getList = getList & " (" & vbCrLf & join(iRows, vbCrLf) & vbCrLf & String(iLevel, vbTab) & ")"
        End If
    End If
Exit_Handler:
    Exit Function
emptyList:
    If Err.Number = 9 Then
        getList = getList & " ()"
    Else
        Resume Next
    End If
End Function
 
'/**
' * Erstellt die Variablen-Zeile ohne Wert
' * iLevel*Tabs [idx] => <Type>
' * @param  Variant     Das zu untersuchende Objekt
' * @param  Integer     Aktueller Level der Verschachtelung
' * @param  Variant     Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  String      Vorgabe eines Datentypes. Ãœberschreibt die automatische erkennung
' * @return String      Verschachteulng & Typentext
' */
Private Function getVarRow( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByVal iType As String = vbNullString _
) As String
    Dim idxs As String
    Dim objS As String: objS = IIf(iType = vbNullString, TypeName(iExpression), iType)
 
    If IsNull(idx) Then
        idxs = ""
    Else
        idxs = replace(C_KEY_PATTERN, "{$idx}", idx)
    End If
 
    If isClassModul(iExpression) Then
        objS = replace(C_CLASSMODUL_TYPE_PATTERN, "{$className}", objS)
        objS = replace(objS, "{$typeName}", getComponentTypeS(iExpression))
    End If
    If (iParams And prShowType) Then
        getVarRow = String(iLevel, vbTab) & idxs & replace(C_TYPE_PATTERN, "{$typeName}", objS) & " "
    Else
        getVarRow = String(iLevel, vbTab) & idxs
    End If
End Function
 
'-------------------------------------------------------------------------------
' Pro Fall habe ich eine private Funktion geschrieben
'-------------------------------------------------------------------------------
 
'/**
' * Native Variable
' * Native Variable oder nicht ausgearbeitetes Objekt
' * @param  Variant     Das zu untersuchende Objekt
' * @param  Integer     Aktueller Level der Verschachtelung
' * @param  Variant     Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  String      Vorgabe eines Datentypes. Ãœberschreibt die automatische erkennung
' * @return String      Text der Verschachtelungs dieses Objektes
' */
Private Function prDefault( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean, _
        Optional ByVal iType As String _
) As String
    Dim pVar As String
    Dim i    As Integer
    Select Case varType(iExpression)
        Case vbNull, vbEmpty, vbDataObject, vbObject
            pVar = vbNullString
        Case vbError
            pVar = "[" & iExpression.Number & "] " & iExpression.Description
        Case vbDouble, vbDecimal, vbDate, vbInteger, vbLong, vbBoolean, vbByte, vbCurrency
            pVar = CStr(iExpression)
        Case Else
            pVar = CStr(iExpression)
            'Escape Space (Muss vor prEscapeNotPrintableChars passieren)
            If (iParams And prEscapeSpaces) Then
                Do While rxSpezChars.test(pVar)
                    pVar = rxSpezChars.replace(pVar, dictTranslateSpezChars(rxSpezChars.execute(pVar)(0).value))
                Loop
            End If
            'Nicht druckbare Zeichen in Unicode wandeln
            If (iParams And prEscapeNotPrintableChars) Then pVar = unicodeSpezChars(pVar)
            'ggf " im Text durch "" ersetzen
            If (iParams And prEscapeDoubleQuotes) Then pVar = replace(pVar, """", """""")
            'Mit Hochkommas umschliessen
            Dim qt As String: qt = IIf(iParams And prStringSingleQuotes, "'", IIf(iParams And prStringDoubleQuotes, """", Empty))
            pVar = qt & pVar & qt
    End Select
 
    'Definition davor schreiben und einrücken
    If andB(iParams, prListSingleLine) Then
        prDefault = getVarRow(iExpression, 0, idx, iParams, iType) & pVar
    Else
        prDefault = getVarRow(iExpression, iLevel, idx, iParams, iType) & pVar
    End If
 
    oValid = True
End Function
 
 
'Sonderzeichen ausserhalb Ascii 32 bis 127 ersetzen. Leerzeichen nicht ersetzen (\u0020d). € Auch nicht ersetzen
Private Function unicodeSpezChars(ByVal iString) As String
    unicodeSpezChars = iString
    Static lastQm As String
'    Static rx As Object: If rx Is Nothing Or stringDelemiter <> lastQm Then Set rx = cRx("/(" & stringDelemiter & "|[^\u0021-\u007e\u0020d]|[\u003a])/i")
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/([^\u0021-\u007e\u0020d\u20AC])/i")
    Do While rx.test(unicodeSpezChars)
        unicodeSpezChars = rx.replace(unicodeSpezChars, char2unicode(rx.execute(unicodeSpezChars)(0).subMatches(0)))
    Loop
End Function
 
 
'/**
' * Dictionary
' * Gibt den print_r String für eine Map zurück. Name => Value
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prGenericKeyList( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfung über das Try & Error Verfahren
On Error GoTo Exit_Handler
 
    Dim rows()  As String
    Dim i As Long
 
    If iExpression.count > 0 Then
        ReDim rows(0 To iExpression.count - 1)
        Dim item As Variant: For Each item In iExpression
            rows(inc(i)) = print_r_priv(item.value, iLevel + 1, item.name, iParams)
        Next
    End If
 
    prGenericKeyList = getList(rows, iExpression, iLevel, idx, iParams)
    oValid = True
Exit_Handler:
    Exit Function
End Function
 
'/**
' * prGenericItemList
' * Gibt eine Liste mit SubItems aus. Die Liste ist mit einem durchgehenden Index versehen
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prGenericItemList( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfung über das Try & Error Verfahren
On Error GoTo Exit_Handler
    Dim rows() As String: ReDim rows(iExpression.count - 1)
    Dim i As Integer
    Dim fld As Object: For Each fld In iExpression
        rows(inc(i)) = print_r_priv(fld, iLevel + 1, "#" & i, iParams)
    Next
    prGenericItemList = getList(rows, iExpression, iLevel, idx, iParams)
    oValid = (i = iExpression.count)
 
Exit_Handler:
    Exit Function
End Function
 
'/**
' * prGenericItemList
' * Gibt eine Liste mit SubItems aus. Die Liste ist mit einem durchgehenden Index versehen
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @param  Long            [IN]    Unterster Index     Standard: 0
' * @param  Long            [IN]    Oberster Index      Standard: iExpression.Count-1
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prGenericIndexList( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean, _
        Optional ByVal iLbound As Long = 0, _
        Optional ByVal iUbound As Long = -1 _
) As String
    'Prüfung über das Try & Error Verfahren
On Error GoTo Exit_Handler
    Dim upperLimit As Long: upperLimit = iUbound
    If iUbound = -1 Then upperLimit = iExpression.count - 1
 
    Dim rows() As String: ReDim rows(iLbound To upperLimit)
    Dim i As Integer: For i = iLbound To upperLimit
        rows(i) = print_r_priv(iExpression(i), iLevel + 1, "#" & i, iParams)
    Next i
    prGenericIndexList = getList(rows, iExpression, iLevel, idx, iParams)
 
    oValid = True
Exit_Handler:
    Exit Function
End Function
 
'/**
' * Array
' * Gibt den print_r String für einen Array zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prArray( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not (IsArray(iExpression) And countArrayDim(iExpression) = 1) Then Exit Function
    'kann als prGenericIndexList mit speziellen Limiten gehandelt werden
    prArray = prGenericIndexList(iExpression, iLevel, idx, iParams, oValid, LBound(iExpression), UBound(iExpression))
End Function
 
'/**
' * Mehrdimensionaler Array
' * Gibt den print_r String für einen Array zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prArrayMDim( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not IsArray(iExpression) Then Exit Function
    oValid = True
 
    Const C_MAX_ALLOWED_DIM = 4
    Dim rows()  As String
    Dim i1, i2, i3, i4
    Dim cntDim  As Long: cntDim = countArrayDim(iExpression)
    Dim pos     As Long: pos = -1
On Error Resume Next
 
    If cntDim > C_MAX_ALLOWED_DIM Then
        ReDim rows(0)
        rows(0) = print_error(0, cntDim & " von " & C_MAX_ALLOWED_DIM & " darstelbaren Dimensionen.", TypeName(iExpression), iLevel + 1, 0)
    Else
        '1te Dimension
        For i1 = LBound(iExpression, 1) To UBound(iExpression, 1)
            If cntDim = 1 Then
                pos = pos + 1: ReDim Preserve rows(pos):
                rows(pos) = print_r_priv(iExpression(i1), iLevel + 1, i1, iParams)
            Else
                '2te Dimension
                For i2 = LBound(iExpression, 2) To UBound(iExpression, 2)
                    If cntDim = 2 Then
                        pos = pos + 1: ReDim Preserve rows(pos):
                        rows(pos) = print_r_priv(iExpression(i1, i2), iLevel + 1, i1 & "." & i2, iParams)
                    Else
                        '3te Dimension
                        For i3 = LBound(iExpression, 3) To UBound(iExpression, 3)
                            If cntDim = 3 Then
                                pos = pos + 1: ReDim Preserve rows(pos):
                                rows(pos) = print_r_priv(iExpression(i1, i2, i3), iLevel + 1, i1 & "." & i2 & "." & i3)
                            Else
                                '4te Dimension
                                For i4 = LBound(iExpression, 4) To UBound(iExpression, 4)
                                    If cntDim = 4 Then
                                        pos = pos + 1: ReDim Preserve rows(pos):
                                        rows(pos) = print_r_priv(iExpression(i1, i2, i3, i4), iLevel + 1, i1 & "." & i2 & "." & i3 & "." & i4)
                                    Else
                                    End If
                                Next i4
                            End If
                        Next i3
                    End If
                Next i2
            End If
        Next i1
    End If
    prArrayMDim = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
'/**
' * Collection
' * Gibt den print_r String für eine Collection zurück
' Die Collection ist ein Sonderfall der prGenericIndexList
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prCollection( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_COLLECTION Then Exit Function
    'kann als prGenericIndexList mit speziellen Limiten gehandelt werden
    'prCollection = prGenericIndexList(iExpression, iLevel, idx, iParams, oValid, 1, iExpression.count)
 
    oValid = True
    Dim keys() As String: keys = getCollectionKeys(iExpression)
 
    Dim rows()  As String
    'Dim i       As Long
 
    If iExpression.count > 0 Then
        ReDim rows(1 To iExpression.count)
        Dim i&: For i = 1 To iExpression.count
            Dim key As Variant: key = IIf(keys(i) = Empty, "#" & i, keys(i))
            rows(i) = print_r_priv(iExpression.item(i), iLevel + 1, key, iParams)
        Next
    End If
    prCollection = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
'/**
' * Dictionary
' * Gibt den print_r String für ein Dictionary zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prDictionary( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_DICTIONARY Then Exit Function
    oValid = True
 
    Dim rows()  As String
    Dim i       As Long
 
    If iExpression.count > 0 Then
        ReDim rows(0 To iExpression.count - 1)
        Dim vkey As Variant: For Each vkey In iExpression.keys
            rows(inc(i)) = print_r_priv(iExpression.item(vkey), iLevel + 1, vkey, iParams)
        Next
    End If
 
    prDictionary = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
 
'/**
' * IRegExp2
' * Gibt den print_r String für ein IRegExp2 zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prRegExp( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_IREGEXP2 Then Exit Function
    oValid = True
 
    Dim rows(3)  As String
 
    rows(0) = print_r_priv(iExpression.pattern, iLevel + 1, "Pattern", iParams)
    rows(1) = print_r_priv(iExpression.Global, iLevel + 1, "Global", iParams)
    rows(2) = print_r_priv(iExpression.IgnoreCase, iLevel + 1, "IgnoreCase", iParams)
    rows(3) = print_r_priv(iExpression.Multiline, iLevel + 1, "Multiline", iParams)
 
    prRegExp = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
'/**
' * IMatch2
' * Gibt den print_r String für ein IMatch2 zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prProperty( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not (TypeName(iExpression) = C_TYPE_property Or TypeName(iExpression) = "AccessProperty") Then Exit Function
    oValid = True
    On Error Resume Next
    Dim val As Variant
    ref val, iExpression.value
    If Err.Number <> 0 Then
        val = "#Error"
    End If
    prProperty = print_r_priv(val, iLevel, iExpression.name, iParams, oValid)
 
End Function
 
'/**
' * IMatch2
' * Gibt den print_r String für ein IMatch2 zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prMatch( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_IMATCH2 Then Exit Function
    oValid = True
 
    Dim rows(2)  As String ': ReDim rows(-2 To iExpression.subMatches.count - 1)
 
    rows(0) = print_r_priv(iExpression.value, iLevel + 1, "Match", iParams)
    rows(1) = print_r_priv(iExpression.firstIndex, iLevel + 1, "FirstIndex", iParams)
    rows(2) = print_r_priv(iExpression.subMatches, iLevel + 1, "SubMatches", iParams)
 
    prMatch = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
'/**
' * ErrorObject
' * Gibt den print_r String für ein ErrorObject zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
'/**
' * ErrorObject
' */
Private Function prError( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_ERROBJECT Then Exit Function
    oValid = True
 
    prError = getVarRow(iExpression, iLevel, idx, iParams) & iExpression.Number & " " & iExpression.Description
End Function
 
'/**
' * DAO.Recordset
' * Es werden Einträge eines DAO.Recordsets ausgegeben. Und von dem Datensatz bei dem der RS übergeben wird.
' * Die Maximale Anzahl Zeilen ist in der Konstante C_RS_MAX_ROWS hinterlegt
' * Die Datentypen sind diejenigen der Tabelle
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prRecordset( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not (TypeName(iExpression) = C_TYPE_DAO_RECORDSET Or TypeName(iExpression) = C_TYPE_ADODB_RECORDSET) Then Exit Function
    oValid = True
 
    Dim rowNr As Integer
    iExpression.MoveFirst
    Dim fields() As String: ReDim fields(iExpression.fields.count - 1)
    Do While Not iExpression.EOF And rowNr < C_RS_MAX_ROWS
        Dim rows() As String: ReDim Preserve rows(rowNr)
 
        Dim fldNr As Integer: For fldNr = 0 To iExpression.fields.count - 1
            With iExpression.fields(fldNr)
                If TypeName(iExpression.fields(fldNr)) = "Field" Then
                    'ADODB
                    fields(fldNr) = prDefault(.value, iLevel + 2, .name, iParams)
                Else
                    'DAO
                    fields(fldNr) = prDefault(.value, iLevel + 2, .name, iParams, , getDaoDbTypeName(.Type, .size))
                End If
            End With
        Next
        rows(inc(rowNr)) = getList(fields, iExpression.fields, iLevel + 1, rowNr, iParams)
        iExpression.MoveNext
    Loop
    If Not iExpression.EOF Then
        ReDim Preserve rows(rowNr)
        rows(rowNr) = print_r_priv("...", iLevel + 1, rowNr)
    End If
    prRecordset = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
'/**
' * Iterator
' * wiki.yaslaw.info/dokuwiki/doku.php/vba/classes/iterator/index
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prIterator( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_ITERATOR Then Exit Function
    oValid = True
 
    Dim rows(14)  As String
    Dim rowNr As Long
On Error Resume Next
    rows(inc(rowNr)) = print_r_priv(iExpression.paramDaoValue, iLevel + 1, "paramDaoValue", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.paramErrorAtEmptyList, iLevel + 1, "paramErrorAtEmptyList", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.paramIndexInsteadKey, iLevel + 1, "paramIndexInsteadKey", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.paramListNextNoParamsAsToNext, iLevel + 1, "paramListNextNoParamsAsToNext", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.paramNothingAsEmptyList, iLevel + 1, "paramNothingAsEmptyList", iParams)
 
    rows(inc(rowNr)) = print_r_priv(iExpression.isInitialized, iLevel + 1, "isInitialized", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.isEmpty, iLevel + 1, "isEmpty", iParams)
 
    rows(inc(rowNr)) = print_r_priv(iExpression.count, iLevel + 1, "count", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.BOF, iLevel + 1, "BOF", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.EOF, iLevel + 1, "EOF", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.absolutePosition, iLevel + 1, "absolutePosition", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.index, iLevel + 1, "index", iParams)
 
    rows(inc(rowNr)) = print_r_priv(iExpression.key, iLevel + 1, "key", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.current, iLevel + 1, "value", iParams)
    rows(inc(rowNr)) = print_r_priv(iExpression.Source, iLevel + 1, "source", iParams)
 
    prIterator = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
'/**
' * DAO.Field2
' * Gibt den print_r String für ein DAO.Field zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prDaoField2( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_FIELD2 Then Exit Function
    oValid = True
 
    Dim rows(3)  As String
    Dim i       As Integer
 
On Error Resume Next
 
    rows(inc(i)) = print_r_priv(iExpression.OrdinalPosition, iLevel + 1, "OrdinalPosition", iParams)
    rows(inc(i)) = print_r_priv(iExpression.name, iLevel + 1, "name", iParams)
    rows(inc(i)) = print_r_priv(iExpression.value, iLevel + 1, "value", iParams)
    rows(inc(i)) = print_r_priv(iExpression.Type, iLevel + 1, "type", iParams)
 
    prDaoField2 = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
'/**
' * FSO.File
' * Gibt den print_r String für ein File zurück
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prFile( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_FILE Then Exit Function
    oValid = True
 
    Dim rows(7)  As String
    Dim i       As Integer
    rows(inc(i)) = print_r_priv(iExpression.name, iLevel + 1, "Name", iParams)
    rows(inc(i)) = print_r_priv(iExpression.DateCreated, iLevel + 1, "DateCreated", iParams)
    rows(inc(i)) = print_r_priv(iExpression.DateLastModified, iLevel + 1, "DateLastModified", iParams)
    rows(inc(i)) = print_r_priv(iExpression.size, iLevel + 1, "Size", iParams)
    rows(inc(i)) = print_r_priv(iExpression.Type, iLevel + 1, "Type", iParams)
    rows(inc(i)) = print_r_priv(iExpression.path, iLevel + 1, "Path", iParams)
    rows(inc(i)) = print_r_priv(iExpression.ShortName, iLevel + 1, "ShortName", iParams)
    rows(inc(i)) = print_r_priv(iExpression.ShortPath, iLevel + 1, "ShortPath", iParams)
 
    prFile = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
'/**
' * FSO.Folder
' * Gibt den print_r String für ein Folder zurück. Es wird nicht der ganze Tree ausgelesen.
' * Es gibt lediglich eine Auflistung der Unterobjekte. Ansonsten wird es schnell zu gross
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant         [IN]    Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prFolder( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not TypeName(iExpression) = C_TYPE_FOLDER Then Exit Function
    oValid = True
 
    Dim rows(11)  As String
    Dim subRows() As String
    Dim f       As Integer
    Dim i       As Integer
    Dim fld     As Object
On Error Resume Next
 
'Dim fl As Scripting.Folder:fl.IsRootFolder
 
    rows(inc(f)) = print_r_priv(iExpression.name, iLevel + 1, "Name", iParams)
    rows(inc(f)) = print_r_priv(iExpression.DateCreated, iLevel + 1, "DateCreated", iParams)
    rows(inc(f)) = print_r_priv(iExpression.DateLastModified, iLevel + 1, "DateLastModified", iParams)
    rows(inc(f)) = print_r_priv(iExpression.size, iLevel + 1, "Size", iParams)
    rows(inc(f)) = print_r_priv(iExpression.Type, iLevel + 1, "Type", iParams)
    rows(inc(f)) = print_r_priv(iExpression.IsRootFolder, iLevel + 1, "IsRootFolder", iParams)
 
    rows(inc(f)) = print_r_priv(iExpression.path, iLevel + 1, "Path", iParams)
    rows(inc(f)) = print_r_priv(iExpression.ParentFolder.path, iLevel + 1, "ParentFolderPath", iParams)
    rows(inc(f)) = print_r_priv(iExpression.ShortName, iLevel + 1, "ShortName", iParams)
    rows(inc(f)) = print_r_priv(iExpression.ShortPath, iLevel + 1, "ShortPath", iParams)
 
    i = 0: ReDim subRows(iExpression.SubFolders.count - 1)
    For Each fld In iExpression.SubFolders
        subRows(inc(i)) = prDefault(fld.name, iLevel + 2, i, iParams, , "Folder")
    Next
    rows(inc(f)) = getList(subRows, iExpression.SubFolders, iLevel + 1, "SubFolders", iParams)
 
    i = 0: ReDim subRows(iExpression.Files.count - 1)
    For Each fld In iExpression.Files
        subRows(inc(i)) = prDefault(fld.name, iLevel + 2, i, iParams, , "File")
    Next
    rows(inc(f)) = getList(subRows, iExpression.Files, iLevel + 1, "Files", iParams)
 
    prFolder = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
Private Function prAccessClass( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    On Error Resume Next
    If Not IsObject(iExpression) Then Exit Function
 
    prAccessClass = prGenericIndexList(iExpression, iLevel, idx, iParams, oValid)
    If oValid Then Exit Function
 
    oValid = True
    Dim rows() As String
    Dim i&, retState As Boolean, retLine$
 
    retLine = print_r_priv(iExpression.name, iLevel + 1, "Name", iParams, retState)
    If retState Then ReDim Preserve rows(i): rows(inc(i)) = retLine
    retLine = print_r_priv(iExpression.ControlType, iLevel + 1, "ControlType", iParams, retState)
    If retState Then ReDim Preserve rows(inc(i)): rows(i) = retLine
 
    'Properties auslesen
    If andB(iParams, prObjPropertiesAsList) Then
        Dim props As properties: Set props = iExpression.properties
        If Err.Number = 0 Then: ReDim Preserve rows(i): rows(inc(i)) = print_r_priv(props, iLevel + 1, "Properties", iParams)
    End If
    prAccessClass = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
Private Function prProperties( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    On Error Resume Next
    If TypeName(iExpression) <> C_TYPE_PROPERTIES Then Exit Function
    oValid = True
    Dim rows()  As String
    Dim i&, row$, paramValid As Boolean
 
    If iExpression.count > 0 Then
        Dim prop As Object: For Each prop In iExpression
            row = prProperty(prop, iLevel + 1, 1, iParams, paramValid)
            If paramValid Then ReDim Preserve rows(i): rows(inc(i)) = row
        Next prop
    End If
 
    prProperties = getList(rows, iExpression, iLevel, idx, iParams)
End Function
 
 
'/**
' * ClassModule
' * Bei einem Objekt aus einem KlassenModul werden alle Property Get() ausgegeben
' * Dazu wird der Code des Klassenmodules nach Property Get mittels Regulärem Ausdruck
' * durchsucht und anschliessend die Wert dazu ausgelesen
' * @param  Variant         [IN]    Das zu untersuchende Objekt
' * @param  Integer         [IN]    Aktueller Level der Verschachtelung
' * @param  Variant     Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung
' *                     ausgegeben wird
' * @param  enuPrintRParams [IN]    Die Print-Paramters
' * @param  Boolean         [OUT]   Rückgabe, ob diese Prozedure zur Expression passt.
' * @return String          [OUT]   Text der Verschachtelungs dieses Objektes
' */
Private Function prClassModule( _
        ByRef iExpression As Variant, _
        ByVal iLevel As Integer, _
        ByVal idx As Variant, _
        ByVal iParams As enuPrintRParams, _
        Optional ByRef oValid As Boolean _
) As String
    'Prüfen ob die Expression den richtigen Type für diese Methode ist
    If Not isClassModul(iExpression) Then Exit Function
    oValid = True
 
    Dim rows()  As String                               'Die Detailzeilen als String
    Dim vc      As Object
    Dim mc As Object
    Dim ln      As String
    Dim tn      As String:  tn = TypeName(iExpression)
    Dim i
    Dim val     As Variant
    Dim pType   As String
 
    Set vc = Application.VBE.ActiveVBProject.VBComponents(tn)
    If vc.name = tn Then
        ln = vc.CodeModule.lines(1, vc.CodeModule.CountOfLines)
        'Jede Zeile gegen den Regulären Ausdruck testen
        If rxClassProperties.test(ln) Then
            Set mc = rxClassProperties.execute(ln)
            ReDim rows(0 To mc.count - 1)
 
            On Error Resume Next
                For i = 0 To mc.count - 1
                    ref val, CallByName(iExpression, mc(i).subMatches(0), VbGet)
                    'Bei Fehler, Fehler ausgeben
                    If Err.Number = 0 Then
                        rows(i) = print_r_priv(val, iLevel + 1, mc(i).subMatches(0))
                    Else
                        pType = IIf(mc(i).subMatches(1) = vbNullString, "Variant", mc(i).subMatches(1))
                        rows(i) = print_error(Err.Number, Err.Description, pType, iLevel + 1, mc(i).subMatches(0))
                    End If
                Next i
            On Error GoTo 0
        End If
    End If
 
    prClassModule = getList(rows, iExpression, iLevel, idx, iParams)
 
    Set vc = Nothing
    Set mc = Nothing
    Exit Function
End Function
 
''/**
'' * gibt den Value oder Feldnamen zurück
'' * @param  Variant     Wert/FeldName oder Array(Wert/FeldName, ..)
'' * @param  eParseType
'' * @return Variant     Formatierter Wert/Feldname oder Array davon
'' */
'Private Function castToSql(ByVal iItem As Variant) As String
'    Select Case varType(iItem)
'        Case evtNumber:      castToSql = iItems
'        'Case vbDate:         castToSql = format(iItems, "\#mm-dd-yyyy\#")
'        Case vbDate:        castToSql = format(iItems, "\#mm-dd-yyyy hh:nn:ss\#")
'        'Case vbDate:         castToSql = format(iItems, "\#hh:nn:ss\#")
'        Case vbBoolean:     castToSql = CStr(iItems)
'        Case vbNull:        castToSql = "NULL"
'        Case Else:           castToSql = """" & iItems & """"
'    End Select
'End Function
'-------------------------------------------------------------------------------
'Private Properties
'-------------------------------------------------------------------------------
 
'/**
' * RegExp um in einem Class-Text die Properties zu finden
' * @return Regexp
' */
Private Property Get rxClassProperties() As Object
    'Ergänzung durch Friedemann Schmidt
    'Variante kann
    ' 1. auch Umlaute in Variable finden
    ' 2. auch "Public Variable As String"
    ' 3. auch "Public Variable$"
    Static pRx As Object: If pRx Is Nothing Then Set pRx = cRx("/^\s*Public (?:Static )?(?:Property )?(?:Get )?(?:Let )?([\wöäüÄÖÜß]+)(?:\(\))?\s*(?:\s+As\s+(\w*)|([&%$]))/gm") '
    'ALte Version
    'Static pRx As Object: If pRx Is Nothing Then Set pRx = cRx("/^\s*Public (?:Static )?Property Get ([\w]+)\(.*\)\s*As\s*(\w*)/gm")
    Set rxClassProperties = pRx
End Property
 
 
 
'/**
' * Spezielle Spaces. Tabulator etc.
' * -> siehe auch dictTranslateSpezChars
' * @return Regexp
' */
Private Property Get rxSpezChars() As Object
    Static pRx As Object: If pRx Is Nothing Then Set pRx = cRx("/[\u0009\u000A\u000C\u000D]/")
    Set rxSpezChars = pRx
End Property
 
'/**
' * Umsetzung Spezieller Zeichen
' * Array(vbTab, vbLf, vbCr, vbFormFeed) -> Array("\t", "\n", "\r", "\f")
' * -> siehe auch rxSpezChars
' * @return Dictionary
' */
Private Property Get dictTranslateSpezChars() As Object
    Static pDict As Object
    If pDict Is Nothing Then
        Set pDict = CreateObject("scripting.Dictionary")
        pDict.add vbTab, "\t"       '\u0009
        pDict.add vbLf, "\n"        '\u000A
        pDict.add vbFormFeed, "\f"  '\u000C
        pDict.add vbCr, "\r"        '\u000D
    End If
    Set dictTranslateSpezChars = pDict
End Property
 
'-------------------------------------------------------------------------------
'Private Libraries
'-------------------------------------------------------------------------------
 
'/**
' * Dies ist die Minimalversion von cRegExp
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cregexp#abgespeckte_version
' * mögliche Delemiter: @&!/~#=\|
' * mögliche Modifiers: g (Global), i (IgnoreCode, m (Mulitline)
' *
' * @example    myRx = cRx("/([a]{2,})/i") 'Finde alle folgen von a. Flag:IgnoreCase
' * @version    2.1.0 (01.12.2014)
' * @param      String      Pattern mit Delimiter und Modifier analog zu PHP
' * @return     Object      RegExp-Object
' */
Private Function cRx(ByVal iPattern As String) As Object
    Static rxP As Object:       Set cRx = CreateObject("VBScript.RegExp")
    If rxP Is Nothing Then:     Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$"
    Dim sm As Object:           Set sm = rxP.execute(iPattern)(0).subMatches
    cRx.pattern = sm(1):        cRx.IgnoreCase = Not isEmpty(sm(2)):       cRx.Global = Not isEmpty(sm(3)):     cRx.Multiline = Not isEmpty(sm(4))
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Charakter in ein Unicode
' * @example: char2unicode("€") -> '\u20AC'
' * @param  String(1)   Charakter, der gewandelt werden soll
' * @return String      Unicode
' */
Private Function char2unicode(ByVal iChar As String) As String
    char2unicode = Hex(AscW(iChar)) 'Hex-Wert ermitteln
    char2unicode = "\u" & String(4 - Len(char2unicode), "0") & char2unicode
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' *
' * Wandelt ein Unicode in ein Charakter
' * @example: unicode2char("\u20AC") -> '\€'
' * @param  String      Unicode
' * @return String      Char
' */
Private Function unicode2Char(ByVal iUnicode As String) As String
    unicode2Char = ChrW(replace(iUnicode, "\u", "&h"))
End Function
 
'/**
' * Zählt die Dimensionen eines mehrdimensionalen Array
' * http://support.microsoft.com/kb/152288/de
' * @example:           Dim a(1, -1 to 2, 4)
' *                     countArrayDim  'Gibt 3
' * @param  Variant     Das zu untersuchende Objekt
' * @return Long        Anzahl Dimensionen (1-60´000)
' */
Private Function countArrayDim(ByVal iExpression As Variant) As Long
    Dim errorCheck  As Long
    Dim dimNum      As Long
On Error GoTo FinalDimension
 
    'Visual Basic for Applications arrays can have up to 60000
    'dimensions; this allows for that.
    For dimNum = 1 To 60000
       'It is necessary to do something with the LBound to force it
       'to generate an error.
       errorCheck = LBound(iExpression, dimNum)
    Next dimNum
' The error routine.
FinalDimension:
    countArrayDim = dimNum - 1
End Function
 
'/**
' * Prüft ob das Objekt von einer User Definirten Klasse stammt
' * @param  Variant     Das zu untersuchende Objekt
' * @return Boolean     True => Objekt ist ein Klassenmodul
' */
Private Function isClassModul(ByVal iExpression As Variant) As Boolean
On Error Resume Next
    isClassModul = (Application.VBE.ActiveVBProject.VBComponents(TypeName(iExpression)).name) = TypeName(iExpression)
    Err.clear
End Function
 
'/**
' * Gibt den Type eines CodeModul zurück
' * @param  Variant     Das zu untersuchende Objekt
' * @return String      Name
' */
Private Function getComponentTypeS(ByVal iExpression As Variant) As String
    Dim vc As Object
    Set vc = Application.VBE.ActiveVBProject.VBComponents(TypeName(iExpression))
 
    'ComponentType As VBIDE.vbext_ComponentType
    Select Case vc.Type
        Case 11:    getComponentTypeS = "ActiveX Designer"  'vbext_ct_ActiveXDesigner
        Case 2:     getComponentTypeS = "Class Module"      'vbext_ct_ClassModule
        Case 100:   getComponentTypeS = "Document Module"   'vbext_ct_Document
        Case 3:     getComponentTypeS = "UserForm"          'vbext_ct_MSForm
        Case 1:     getComponentTypeS = "Code Module"       'vbext_ct_StdModule
        Case Else:  getComponentTypeS = "Unknown Type: " & CStr(vc.Type)
    End Select
End Function
 
'/**
' * Gibt den Ausgeschriebenen Namen eines DataTypeEnum aus
' * @param  Integer     DateTypeEnum
' * @param  Integer     Grösse
' * @return String      Name inkl. Grösse
' */
Private Function getDaoDbTypeName( _
        ByVal iDbType As Integer, _
        ByVal iSize As Integer _
) As String
    Static pDict As Object
    If pDict Is Nothing Then
        Set pDict = CreateObject("scripting.Dictionary")
        pDict.add 16, "Big Integer"                       'dbBigInt
        pDict.add 9, "Binary"                             'dbBinary
        pDict.add 1, "Boolean"                            'dbBoolean
        pDict.add 2, "Byte"                               'dbByte
        pDict.add 18, "Char"                              'dbChar
        pDict.add 5, "Currency"                           'dbCurrency
        pDict.add 8, "Date/Time"                          'dbDate
        pDict.add 20, "Decimal"                           'dbDecimal
        pDict.add 7, "Double"                             'dbDouble
        pDict.add 21, "Float"                             'dbFloat
        pDict.add 15, "GUID"                              'dbGUID
        pDict.add 3, "Integer"                            'dbInteger
        pDict.add 4, "Long"                               'dbLong
        pDict.add 11, "Long Binary (OLE Object)"          'dbLongBinary
        pDict.add 12, "Memo"                              'dbMemo
        pDict.add 19, "Numeric"                           'dbNumeric
        pDict.add 6, "Single"                             'dbSingle
        pDict.add 10, "Text"                              'dbText
        pDict.add 22, "Time"                              'dbTime
        pDict.add 23, "Time Stamp"                        'dbTimeStamp
        pDict.add 17, "VarBinary"                         'dbVarBinary
    End If
    getDaoDbTypeName = IIf(pDict.exists(iDbType), pDict(iDbType), "N/A")
    If IIf(IsNull(iSize), 0, iSize) > 0 Then getDaoDbTypeName = getDaoDbTypeName & "(" & iSize & ")"
End Function
 
'/**
' *Text in den Zwieschenspeicher des PCs schreiben
'  * @see   http://desmondoshiwambo.wordpress.com/2012/02/23/how-to-copy-and-paste-text-tofrom-clipboard-using-vba-microsoft-access/
' */
Private Sub toClipboard(ByVal inText As String)
     Dim objClipboard As Object
     Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
 
     objClipboard.SetText inText
     objClipboard.PutInClipboard
 
     Set objClipboard = Nothing
End Sub
 
'/**
' * @param  Number
' * @param  incType     Type der Encrementation. Default ist i++
' * @retrun Number
'*/
Private Function inc(ByRef i As Variant) As Variant
    inc = i:    i = i + 1   'i++
End Function
 
'/**
' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht.
' * Diese Sub nimmt einem die Arbeit ab
' * @example ref a, b   'Entspricht a = b oder Set a  b
' * @param  Variant     Variable, die den Wert bekommen soll
' * @param  Variant     Ret Wert selber
' */
Private Sub ref(ByRef oNode As Variant, ByRef iNode As Variant)
    If IsObject(iNode) Then
        Set oNode = iNode
    Else
        oNode = iNode
    End If
End Sub
 
'/**
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/andb
' * Macht einen Bit-Vergleich
' * @param  Long
' * @param  Long
' * @return Boolean
' */
Private Function andB(ByVal iHaystack As Long, ByVal iNeedle As Long) As Boolean
    andB = ((iHaystack And iNeedle) = iNeedle)
End Function
 
Private Function getCollectionKeys(ByRef iCollection As Variant) As String()
#If Win64 Then
    Const ecDelta = 28
    Const nextDelta = 40
    Dim CollPtr As LongPtr: CollPtr = VBA.ObjPtr(iCollection)     'Get MemoryAddress of Collection Object
    Dim KeyPtr As LongPtr
    Dim ItemPtr As LongPtr
#Else
    Const ecDelta = 16
    Const nextDelta = 24
    Dim CollPtr As Long:    CollPtr = VBA.ObjPtr(iCollection)     'Get MemoryAddress of Collection Object
    Dim KeyPtr As Long
    Dim ItemPtr As Long
#End If
 
    Dim ElementCount As Long:   ElementCount = PeekLong(CollPtr + ecDelta)      'Peek ElementCount
    If ElementCount <> iCollection.count Then Stop                                    'Verify ElementCount
 
    Dim Temp() As String: ReDim Temp(1 To ElementCount)                         'Declare Temporary Array to hold our keys
    ItemPtr = PeekLong(CollPtr + nextDelta)                                     'Get MemoryAddress of first CollectionItem
 
    'Loop through all CollectionItems in Chain
    Dim index As Long: While Not ItemPtr = 0 And index < ElementCount
        index = index + 1
 
        KeyPtr = PeekLong(ItemPtr + ecDelta)                                    'Get MemoryAddress of Element-Key
        If KeyPtr <> 0 Then Temp(index) = PeekBSTR(KeyPtr)                      'Peek Key and add to temporary array (if present)
        ItemPtr = PeekLong(ItemPtr + nextDelta)                                 'Get MemoryAddress of next Element in Chain
 
    Wend
    getCollectionKeys = Temp
End Function
 
 
'Peek Long from given MemoryAddress
 
#If Win64 Then
    'Peek LongLong from given Memory Address
    Private Function PeekLong(Address As LongPtr) As LongLong
      If Address = 0 Then Stop
      Call MemCopy(VBA.VarPtr(PeekLong), Address, 8&)
    End Function
#Else
    Private Function PeekLong(Address As Long) As Long
      If Address = 0 Then Stop
      Call MemCopy(VBA.VarPtr(PeekLong), Address, 4&)
    End Function
#End If
 
'Peek String from given MemoryAddress
Private Function PeekBSTR(Address As Long) As String
    If Address = 0 Then Stop
    Dim Length As Long: Length = PeekLong(Address - 4)
    PeekBSTR = Space(Length \ 2)
#If Win64 Then
    Call MemCopy(VBA.StrPtr(PeekBSTR), Address, CLngLng(Length))
#Else
    Call MemCopy(VBA.StrPtr(PeekBSTR), Address, Length)
#End If
End Function