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: ' 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 ' */ 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 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] => ' * @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