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.6.0 'Name : printR 'Author : Stefan Erb (ERS) 'History : 16.10.2013 - 1.0.0 - ERS - Creation ' ... ' 23.07.2015 - 2.5.0 - ERS - Conditional Compilation für die versch. Office Programme eingeführt ' 31.08.2015 - 2.6.0 - ERS - Fehlermelugn und #debugMode eingeführt ' '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 isAccess = True #Const isExcel = False 'Excel unterstützt keine TempVars und Properties #Const isWord = False 'Muss noch überprüft werden, welche Dinge unter Word nicht funktionieren #Const debugMode = False 'Zu Debugzwekcen das Errorhandling ausschalten '------------------------------------------------------------------------------- ' Private Members '------------------------------------------------------------------------------- '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 '------------------------------------------------------------------------------- ' 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 prEscapeNotPrintableChars = 2 ^ 5 'Nicht Druckbare Zeichen als Unicode ausgeben '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 (iReturn And prConsole) Then Debug.Print retVal 'Wert zurückgeben If (iReturn And prReturn) Then print_r = retVal 'Wert in die Zwieschenablage kopieren If (iReturn And prClipboard) Then toClipboard retVal 'Wert als MsgBox ausgeben If (iReturn And prMsgBox) Then MsgBox retVal Exit Function Err_Handler: retVal = "Error in print_f: [" & Err.source & "] #" & Err.Number & " " & Err.Description GoTo 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 '/** ' * 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 '------------------------------------------------------------------------------- ' 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 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 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 _ ) As String 'Array If IsArray(iExpression) Then If countArrayDim(iExpression) = 1 Then 'Eindimensionaler Array print_r_priv = prArray(iExpression, iLevel, idx, iParams) Else 'Mehrdimensionaler Array print_r_priv = prArrayMDim(iExpression, iLevel, idx, iParams) End If Exit Function End If 'Restliche Typen über den typeName() bestimmen Select Case TypeName(iExpression) Case "ErrObject": print_r_priv = prError(iExpression, iLevel, idx, iParams) 'Collection Case "Collection": print_r_priv = prCollection(iExpression, iLevel, idx, iParams) 'Dictionary Case "Dictionary": print_r_priv = prDictionary(iExpression, iLevel, idx, iParams) #If isAccess Then 'TempVars Case "TempVars": print_r_priv = prTempVars(iExpression, iLevel, idx, iParams) 'Properties Case "Properties": print_r_priv = prProperties(iExpression, iLevel, idx, iParams) #End If 'IRegExp2 Case "IRegExp2": print_r_priv = prRegExp(iExpression, iLevel, idx, iParams) 'IMatchCollection2 Case "IMatchCollection2": print_r_priv = prMatchCollection(iExpression, iLevel, idx, iParams) 'IMatch2 Case "IMatch2": print_r_priv = prMatch(iExpression, iLevel, idx, iParams) 'ISubMatches Case "ISubMatches": print_r_priv = prSubMatches(iExpression, iLevel, idx, iParams) 'DAO Recordset Case "Recordset2": print_r_priv = prRecordset(iExpression, iLevel, idx, iParams) 'Iterator Case "Iterator": print_r_priv = prIterator(iExpression, iLevel, idx, iParams) 'Native Datentypen Case "Fields": print_r_priv = prDaoFields(iExpression, iLevel, idx, iParams) Case "Field2": print_r_priv = prDaoField2(iExpression, iLevel, idx, iParams) Case Else: 'ClassModul If isClassModul(iExpression) Then print_r_priv = prClassModule(iExpression, iLevel, idx, iParams) Exit Function End If print_r_priv = prDefault(iExpression, iLevel, idx, iParams) End Select 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 ' * @retrun 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 ' * @retrun 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 (UBound(iRows) - LBound(iRows) + 1) > 0 Then getList = getList & " (" & vbCrLf & Join(iRows, vbCrLf) & vbCrLf & String(iLevel, vbTab) & ")" 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 ' * @retrun 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 ' * @retrun 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 ByVal iType As String = vbNullString _ ) As String Dim pVar As String Dim i As Integer Dim char As String * 1 Dim qt As String: qt = Empty 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) 'Nicht druckbare Zeichen in Unicode wandeln If (iParams And prEscapeNotPrintableChars) Then 'http://office.microsoft.com/de-ch/help/entfernen-von-leerzeichen-und-nicht-druckbaren-zeichen-aus-text-HP010062743.aspx 'druckbare Zeichen (die Werte 0 bis 31, 127, 129, 141, 143, 144 und 157 im Unicode-Zeichensatz). 'exkl. 9: vbtab, 13: vbCr, 10: vbLf, 12 vbFormFeed For i = Len(pVar) To 1 Step -1 char = Mid(pVar, i, 1) If find_in_set(Asc(char), "0,1,2,3,4,5,6,7,8,11,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,127,129,141,141,144,157") Then pVar = replaceIndex(pVar, char2unicode(char), i - 1, 1) End If Next i End If 'Escape Space If (iParams And prEscapeSpaces) Then pVar = replaceA(pVar, Array(vbTab, vbLf, vbCr, vbFormFeed), Array("\t", "\n", "\r", "\f")) 'ggf " im Text durch "" ersetzen If (iParams And prEscapeDoubleQuotes) Then pVar = replace(pVar, """", """""") 'Mit Hochkommas umschliessen qt = IIf(iParams And prStringSingleQuotes, "'", IIf(iParams And prStringDoubleQuotes, """", Empty)) pVar = qt & pVar & qt End Select 'Definition davor schreibne und einrücken prDefault = getVarRow(iExpression, iLevel, idx, iParams, iType) & pVar End Function '/** ' * Array ' * Gibt den print_r String für einen Array zurück ' * @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 ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prArray( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim i As Integer On Error Resume Next ReDim rows(LBound(iExpression) To UBound(iExpression)) For i = LBound(iExpression) To UBound(iExpression) rows(i) = print_r_priv(iExpression(i), iLevel + 1, i, iParams) Next i prArray = getList(rows, iExpression, iLevel, idx, iParams) End Function '/** ' * Mehrdimensionaler Array ' * Gibt den print_r String für einen Array zurück ' * @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 ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prArrayMDim( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String 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 ' * @param Variant Die zu untersuchende Collection ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prCollection( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim i As Integer Dim Col As Collection: Set Col = iExpression ReDim rows(1 To Col.count) For i = 1 To Col.count rows(i) = print_r_priv(Col.item(i), iLevel + 1, i, iParams) Next i Set Col = Nothing prCollection = getList(rows, iExpression, iLevel, idx, iParams) End Function '/** ' * Dictionary ' * Gibt den print_r String für ein Dictionary zurück ' * @param Variant Die zu untersuchende Collection ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prDictionary( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim vkey As Variant Dim i As Long: i = 0 ' Dim dict As Scripting.Dictionary: Set dict = iExpression Dim dict As Object: Set dict = iExpression If dict.count > 0 Then ReDim rows(0 To dict.count - 1) For Each vkey In dict.keys rows(i) = print_r_priv(dict.item(vkey), iLevel + 1, vkey, iParams) i = i + 1 Next End If Set dict = Nothing prDictionary = getList(rows, iExpression, iLevel, idx, iParams) End Function #If isAccess Then '/** ' * Dictionary ' * Gibt den print_r String für die TempVars zurück ' * @param Variant Die zu untersuchende Collection ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prTempVars( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim item As TempVar Dim i As Long: i = 0 Dim vars As TempVars: Set vars = iExpression If vars.count > 0 Then ReDim rows(0 To vars.count - 1) For Each item In vars rows(i) = print_r_priv(item.value, iLevel + 1, item.Name, iParams) i = i + 1 Next End If Set vars = Nothing prTempVars = getList(rows, iExpression, iLevel, idx, iParams) End Function #End If #If isAccess Then '/** ' * Dictionary ' * Gibt den print_r String für Properties zurück ' * @param Variant Die zu untersuchende Collection ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prProperties( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim item As Property Dim i As Long: i = 0 Dim vars As properties: Set vars = iExpression If vars.count > 0 Then ReDim rows(0 To vars.count - 1) For Each item In vars rows(i) = print_r_priv(item.value, iLevel + 1, item.Name, iParams) i = i + 1 Next End If Set vars = Nothing prProperties = getList(rows, iExpression, iLevel, idx, iParams) End Function #End If '/** ' * IRegExp2 ' * Gibt den print_r String für ein IRegExp2 zurück ' * @referenz ' * @param Variant Die zu untersuchende Collection ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prRegExp( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows(3) As String Dim rx As Object: Set rx = iExpression Dim nLvl As Integer: nLvl = iLevel + 1 rows(0) = print_r_priv(rx.pattern, nLvl, "Pattern", iParams) rows(1) = print_r_priv(rx.Global, nLvl, "Global", iParams) rows(2) = print_r_priv(rx.IgnoreCase, nLvl, "IgnoreCase", iParams) rows(3) = print_r_priv(rx.Multiline, nLvl, "Multiline", iParams) Set rx = Nothing prRegExp = getList(rows, iExpression, iLevel, idx, iParams) End Function '/** ' * IMatchCollection2 ' * Gibt den print_r String für ein IMatchCollection2 zurück ' * @referenz ' * @param Variant Die zu untersuchende Collection ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prMatchCollection( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim i As Integer ' Dim mc As VBScript_RegExp_55.MatchCollection: Set mc = iExpression Dim mc As Object: Set mc = iExpression If mc.count > 0 Then ReDim rows(0 To mc.count - 1) For i = 0 To mc.count - 1 rows(i) = print_r_priv(mc.item(i), iLevel + 1, i, iParams) Next i End If Set mc = Nothing prMatchCollection = getList(rows, iExpression, iLevel, idx, iParams) End Function '/** ' * IMatch2 ' * Gibt den print_r String für ein IMatch2 zurück ' * @referenz ' * @param Variant Der zu untersuchende Match ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prMatch( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim i As Integer Dim ma As Object: Set ma = iExpression ReDim rows(-2 To ma.subMatches.count - 1) rows(-2) = print_r_priv(ma.value, iLevel + 1, "Match", iParams) rows(-1) = print_r_priv(ma.firstIndex, iLevel + 1, "FirstIndex", iParams) rows(0) = prSubMatches(ma.subMatches, iLevel + 1, "SubMatches", iParams) Set ma = Nothing prMatch = getList(rows, iExpression, iLevel, idx, iParams) End Function '/** ' * ISubMatches ' * Gibt den print_r String für ein ISubMatches zurück ' * @referenz ' * @param Variant Die zu untersuchende ISubMatches-Collection ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prSubMatches( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim sm As Object: Set sm = iExpression Dim rows() As String: ReDim rows(0 To sm.count - 1) Dim i As Integer For i = 0 To sm.count - 1 rows(i) = print_r_priv(sm(i), iLevel + 1, i, iParams) Next i Set sm = Nothing prSubMatches = getList(rows, iExpression, iLevel, idx, iParams) End Function '/** ' * ErrorObject ' * Gibt den print_r String für ein ErrorObject zurück ' * @param Variant Die zu untersuchende Collection ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String 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 _ ) As String Dim pVar As String pVar = iExpression.Number & " " & iExpression.Description prError = getVarRow(iExpression, iLevel, idx, iParams) & pVar 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 Das zu untersuchende Objekt ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prRecordset( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rs As Object: Set rs = iExpression: Dim fld As Object 'DAO.field Dim fields() As String Dim rows() As String Dim i As Integer Dim j As Integer: j = 0 ReDim fields(rs.fields.count - 1) Do While Not rs.EOF And j < C_RS_MAX_ROWS ReDim Preserve rows(j) For i = 0 To rs.fields.count - 1 Set fld = rs.fields(i) fields(i) = prDefault(fld.value, iLevel + 2, fld.Name, iParams, getDaoDbTypeName(fld.Type, fld.size)) 'fields(i) = print_r_priv(fld.value, iLevel + 2, fld.Name) Next rows(j) = getList(fields, rs.fields, iLevel + 1, j, iParams) rs.MoveNext j = j + 1 Loop If Not rs.EOF Then ReDim Preserve rows(j) rows(j) = print_r_priv("...", iLevel + 1, j) End If prRecordset = getList(rows, iExpression, iLevel, idx, iParams) End Function '/** ' * Iterator ' * wiki.yaslaw.info/dokuwiki/doku.php/vba/classes/iterator/index ' * @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 ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prIterator( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim it As Object: Set it = iExpression Dim bookmark As Integer: bookmark = it.index it.reset On Error Resume Next ReDim rows(-5 To it.count - 1) rows(-5) = print_r_priv(it.paramDaoValue, iLevel + 1, "paramDaoValue", iParams) rows(-4) = print_r_priv(it.paramErrorAtEmptyList, iLevel + 1, "paramErrorAtEmptyList", iParams) rows(-3) = print_r_priv(it.paramIndexInsteadKey, iLevel + 1, "paramIndexInsteadKey", iParams) rows(-2) = print_r_priv(it.paramListNextNoParamsAsToNext, iLevel + 1, "paramListNextNoParamsAsToNext", iParams) rows(-1) = print_r_priv(it.paramNothingAsEmptyList, iLevel + 1, "paramNothingAsEmptyList", iParams) Do While it.toNext rows(it.absolutePosition) = print_r_priv(it.current, iLevel + 1, it.KEY, iParams) Loop prIterator = getList(rows, it, iLevel, idx, iParams) it.toPosition bookmark End Function '/** ' * DAO.Fields ' * Gibt den print_r String für eine DAO.Fields-Liste zurück ' * @param Variant Die zu untersuchende Fields ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prDaoFields( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String Dim i As Integer On Error Resume Next ReDim rows(iExpression.count - 1) For i = 0 To (iExpression.count - 1) rows(i) = print_r_priv(iExpression(i), iLevel + 1, iExpression(i).Name, iParams) Next i prDaoFields = getList(rows, iExpression, iLevel, idx, iParams) End Function '/** ' * DAO.Field2 ' * Gibt den print_r String für ein DAO.Field zurück ' * @param Variant Das zu untersuchende Field ' * @param Integer Aktueller Level der Verschachtelung ' * @param Variant Aktueller Index/Key, mit dem dieses Objekt in der Verschachtelung ausgegeben wird ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prDaoField2( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows(3) As String Dim i As Integer On Error Resume Next rows(0) = print_r_priv(iExpression.OrdinalPosition, iLevel + 1, "OrdinalPosition", iParams) rows(1) = print_r_priv(iExpression.Name, iLevel + 1, "name", iParams) rows(2) = print_r_priv(iExpression.value, iLevel + 1, "value", iParams) rows(3) = print_r_priv(iExpression.Type, iLevel + 1, "type", iParams) prDaoField2 = 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 ' * @referenz ' * @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 ' * @retrun String Text der Verschachtelungs dieses Objektes ' */ Private Function prClassModule( _ ByRef iExpression As Variant, _ ByVal iLevel As Integer, _ ByVal idx As Variant, _ ByVal iParams As enuPrintRParams _ ) As String Dim rows() As String 'Die Detailzeilen als String Dim vc As Object ' Dim vc As VBComponent 'Das Classenmodul ' Dim rx As New VBScript_RegExp_55.regexp ' ' Dim mc As VBScript_RegExp_55.MatchCollection Dim rx As Object: Set rx = CreateObject("VBScript.RegExp") 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 'RegExp zum durhsuchen des Klassenmoduls vorbereiten rx.Global = True rx.IgnoreCase = False rx.Multiline = True rx.pattern = "^Public (?:Static )?Property Get ([\w]+)\(.*\)\s*As\s*(\w*)" 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 rx.test(ln) Then Set mc = rx.execute(ln) ReDim rows(0 To mc.count - 1) On Error Resume Next For i = 0 To mc.count - 1 val = CallByName(iExpression, mc(i).subMatches(0), VbGet) 'Rückgabewert ist ein Objekt. Ergo mit Set nochmals probieren If Err.Number = 450 Then Err.Clear Set val = CallByName(iExpression, mc(i).subMatches(0), VbGet) End If '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 Set rx = Nothing Exit Function End Function '------------------------------------------------------------------------------- 'Private Funktion zu prClassModule() '------------------------------------------------------------------------------- '/** ' * Analog zu MySQL FIND_IN_SET() ' * Kann in Access vor allem bei nichtnormalisierten Tabellen verwendet werden ' * @param String Element das gesucht wird ' * @param String Das Set von Elementen, mit Komma getrennt ' * @return Integer oder False ' * @example If find_in_set("d", "a,b,c,d") Then ... ' * @example SELECT ... WEHRE find_in_set('d', field1) ' */ Private Function find_in_set(ByVal iSearch As String, ByVal iSet As String) As Variant Dim parts() As String Dim index As Integer On Error GoTo Err_Handler find_in_set = False parts = Split(iSet, ",") For index = 0 To UBound(parts) If Trim(parts(index)) = iSearch Then find_in_set = index + 1 Exit For End If Next index Exit Function Err_Handler: find_in_set = False End Function '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Ersetzt ein pestimmte Position in einem String ' * @param String Heystack ' * @param String Ersetzungsstring ' * @param Integer Position im String ' * @param Integer Länge des zu ersetzenden Strings ' */ Private Function replaceIndex(ByVal iExpression As Variant, ByVal iReplace As Variant, ByVal iIndex As Integer, Optional ByVal iLength As Integer = 1) As String replaceIndex = Left(iExpression, iIndex) & iReplace & Mid(iExpression, iIndex + iLength + 1) 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 Dim tn As String: tn = TypeName(iExpression) isClassModul = False On Error Resume Next isClassModul = (application.VBE.ActiveVBProject.VBComponents(tn).Name) = tn 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 'vbext_ct_ActiveXDesigner getComponentTypeS = "ActiveX Designer" Case 2 'vbext_ct_ClassModule getComponentTypeS = "Class Module" Case 100 'vbext_ct_Document getComponentTypeS = "Document Module" Case 3 'vbext_ct_MSForm getComponentTypeS = "UserForm" Case 1 'vbext_ct_StdModule getComponentTypeS = "Code Module" 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 Select Case iDbType Case 16: getDaoDbTypeName = "Big Integer" 'dbBigInt Case 9: getDaoDbTypeName = "Binary" 'dbBinary Case 1: getDaoDbTypeName = "Boolean" 'dbBoolean Case 2: getDaoDbTypeName = "Byte" 'dbByte Case 18: getDaoDbTypeName = "Char" 'dbChar Case 5: getDaoDbTypeName = "Currency" 'dbCurrency Case 8: getDaoDbTypeName = "Date/Time" 'dbDate Case 20: getDaoDbTypeName = "Decimal" 'dbDecimal Case 7: getDaoDbTypeName = "Double" 'dbDouble Case 21: getDaoDbTypeName = "Float" 'dbFloat Case 15: getDaoDbTypeName = "GUID" 'dbGUID Case 3: getDaoDbTypeName = "Integer" 'dbInteger Case 4: getDaoDbTypeName = "Long" 'dbLong Case 11: getDaoDbTypeName = "Long Binary (OLE Object)" 'dbLongBinary Case 12: getDaoDbTypeName = "Memo" 'dbMemo Case 19: getDaoDbTypeName = "Numeric" 'dbNumeric Case 6: getDaoDbTypeName = "Single" 'dbSingle Case 10: getDaoDbTypeName = "Text" 'dbText Case 22: getDaoDbTypeName = "Time" 'dbTime Case 23: getDaoDbTypeName = "Time Stamp" 'dbTimeStamp Case 17: getDaoDbTypeName = "VarBinary" 'dbVarBinary Case Else: getDaoDbTypeName = "N/A" End Select 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 '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/index#replacea ' * ' * @example: str = replaceA("abcd", array("a", "c"), "_") '_b_d ' * @example: str = replaceA("abcd", array("a", "c"), array("A", "C") 'AbCd ' * ' * @example: str = replaceA("abcd", array("a", "c"), "_") '_b_d ' * @example: str = replaceA("abcd", array("a", "c"), array("A", "C") 'AbCd ' * @param Variant expression containing substring to replace. ' * @param Array find Required. Substring being searched for. ' * @param Array or String replace Required. Replacement substring. ' * @param Long Siehe VB-Doku zu replace() ' * @param Long Siehe VB-Doku zu replace() ' * @param VbCompareMethod Siehe VB-Doku zu replace() ' * 2return String ' */ Private Function replaceA( _ ByVal iExpression As Variant, _ ByVal iFind As Variant, _ ByVal iReplace As Variant, _ Optional ByVal iStart As Long = 1, _ Optional ByVal iCount As Long = -1, _ Optional ByVal iCompare As VbCompareMethod = vbBinaryCompare _ ) As String 'Sicherstellen, dass wir einen String haben Dim str As String: str = CStr(IIf(IsNull(iExpression), Empty, iExpression)) 'Sicherstellen, dass filnd ein Array as iFind ist Dim find As Variant: find = IIf(IsArray(iFind), iFind, Array(iFind)) 'Sicherstellen, dass repl ein Array aus iReplace ist Dim repl As Variant: repl = IIf(IsArray(iReplace), iReplace, Array(iReplace)) Dim i As Integer 'Die Arrays miteinander abstimmen. Wenn find mehr einträge als repl hat, so 'wird der Rest bei repl mit seinem letzten Eintrag aufgefüllt. For i = UBound(repl) + 1 To UBound(find) ReDim Preserve repl(i) repl(i) = repl(0) Next i 'Pro find ein Replace ausführen For i = 0 To UBound(find) str = replace(str, CStr(find(i)), CStr(repl(i)), iStart, iCount, iCompare) Next i 'return replaceA = str End Function