Attribute VB_Name = "lib_json" '------------------------------------------------------------------------------- 'File : lib_json.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/json 'Environment : VBA 2010+: getestet mit MS Access 2010 & MS Excel 2010 'Version : 2.9.1 'Name : json 'Author : Stefan Erb (ERS) 'History : 19.02.2014 - ERS - Creation ' ... ' 16.09.2019 - ERS - bei json2obj eine Stringeingabe mit Paramter hinzugefügt ' 17.09.2019 - ERS - Fehler in cVal korrigiert ' 09.10.2019 - ERS - Div. kleine Fehler behoben ' 14.10.2019 - ERS - Json to Collection um die Keys ergänzt ' 17.10.2019 - ERS - Bei json2Dict Führende Leerzeichen beim Key entfernt ' 24.10.2019 - ERS - ' Maskieren hinzugefügt. Wichtg:! jqmDefault von jqmDoubleQuote auf jqmSingleQuote + jqmMask gewechselt ' 16.01.2020 - ERS - cV() korrigiert, damit zB der String Name nicht ausgeführt wird ' 'http://de.wikipedia.org/wiki/JavaScript_Object_Notation '------------------------------------------------------------------------------- Option Explicit '------------------------------------------------------------------------------- ' -- ! SETTINGS ! '------------------------------------------------------------------------------- 'In Excel und Word funktionieren Eval() nicht. Auch der NZ() gibt es dort nicht. 'Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts datzu keine Systemvariable #Const IS_ACCESS = True '------------------------------------------------------------------------------- ' Public Members '------------------------------------------------------------------------------- '/** ' * Einstellungen, ob [...] in ein Array oder in eine Collection geschrieben werden soll ' */ Public Enum jsonDecodeParams jrtCollection = 2 ^ 1 '[c] Als Collection jrtArray = 2 ^ 2 '[a] Als Array jrtDictionary = 2 ^ 3 '[d] Als Dictionary jrtNotCastValue = 2 ^ 4 '[n] cast der Values verhindern jrtEmptyList = 2 ^ 5 '[L] Angabe, ob bei einem Leeren String eine Collection/Array/Dictionary zurückgegeben werden soll jrtEmptyDictionary = 2 ^ 7 '[D] bei jrtEmptyList wird anhand von jrtDictionary etc. bestimmt was es sein soll. jrtDictionary jedoch parst nachher alles in ein Dictionary. DIeses Setting nur Empty jrtSingle2List = 2 ^ 6 '[S] Parst ein einzelnesItem zu einer Liste (Input ist kein Json-String) jrtDefault = jrtArray End Enum '/** ' * Einstellung, ob Strings im JSON in ' oder in " gefasst werden sollen ' */ Public Enum jsonEncodeParams jqmDoubleQuote = 2 ^ 1 'Umfasst die Values mit einem " jqmSingleQuote = 2 ^ 2 'Umfasst die Values mit einem ' jqmForceObject = 2 ^ 3 'Wandelt Arrays in Objekte (Dictionaries) jqmInternalArrayPrefix = 2 ^ 4 'Der JSON-String wird mit eigenen Prefixen bei Array und Collection mitgeliefert jqmReverseSolidusAsUnicode = 2 ^ 5 'Ein \ in einem String wird nicht als \\ sondern als Unicode gaparst jqmNoErrorForWrongType = 2 ^ 6 'Wenn ein nicht parsbarer Wert kommt, den TypeName() ausgeben jqmSingle2Array = 2 ^ 7 'Einzelwerte als Array ausgeben jqmNoUnicode = 2 ^ 8 'Keine Sonderzeichen in Unicode wandeln jqmUnicodeInsteadOfMask = 2 ^ 9 'Anstelle von Maskierungen werden '[{ etc. mit unicode dargestellt jqmDefault = jqmSingleQuote End Enum Public Const JSON_ERROR_INVALID_INPUT = vbObjectError + 1 '------------------------------------------------------------------------------- ' Private Members '------------------------------------------------------------------------------- 'ISO 8601 :standard: "2012-03-19T07:22Z". 'Datums-Format nach ISO 8601 Public Const C_OBJ2JSON_DATE_FORMAT_DEFAULT = "YYYY-MM-DD\T" Public Const C_OBJ2JSON_TIME_FORMAT_DEFAULT = "HH:NN:SS\Z" Public Const C_OBJ2JSON_TIMESTAMP_FORMAT_DEFAULT = "YYYY-MM-DD\THH:NN:SS\Z" Public Const C_JSON2OBJ_TIMESTAMP_PATTERN = "/^(?:['""]?(\d{4}-\d{2}-\d{2})T)?(?:(\d{2}:\d{2}:\d{2})Z['""]?)?$/i" Public Const C_JSON2OBJ_TIMESTAMP_REPLACE = "['""]?$1 $2['""]?" 'Unicode eines \ Private Const C_UNICODE_BACKSLASH = "\u005C" Private Const C_UNICODE_ = "\u003A" Private Enum cvHandling cvhNullTextAsNull = 2 ^ 0 'Der Text Null ohne Delemiter wird als Wert Null intepretiert cvhEmptyAsNull = 2 ^ 1 'Ein leerer String wird als Null intepretiert cvhNotCast = 2 ^ 2 End Enum Private Declare Function emptyArrayVariant Lib "oleaut32" Alias "SafeArrayCreateVector" (Optional ByVal vt As VbVarType = vbVariant, Optional ByVal lLow As Long = 0, Optional ByVal lCount As Long = 0) As Variant() '------------------------------------------------------------------------------- '-- Private members for cDict() '------------------------------------------------------------------------------- 'Private rxCachedSetString As Object Private o2jParams As jsonEncodeParams 'Die jsonEncode-Paramters Private stringDelemiter As String * 1 'Delemter des aktuellen String Private j2oParams As jsonDecodeParams Private pDateFormat As String Private pTimeFormat As String Private pTimeStampFormat As String Private pTimeStampTemplate As String Private pTimeStampReplace As String Private pJ2ORxDate As Object: '------------------------------------------------------------------------------- ' Object to JSON '------------------------------------------------------------------------------- '/** ' * Erstellt aus Directories, Collections und Arrays einen JSON-String ' * @param Objekt ' * @param jsonEncodeParams Angabe über die Art der Anführungszeichen im JSON-String ' * @return String ' */ Public Function obj2json(ByRef iObj As Variant, Optional ByVal iEncodeParams As jsonEncodeParams = jqmDefault) As String o2jParams = iEncodeParams stringDelemiter = IIf(andB(iEncodeParams, jqmDoubleQuote), """", "'") If Not (IsArray(iObj) Or TypeName(iObj) = "Collection" Or TypeName(iObj) = "Dictionary") Then If andB(iEncodeParams, jqmSingle2Array) Then iObj = Array(iObj) ElseIf andB(iEncodeParams, jqmNoErrorForWrongType) Then iObj = "<" & TypeName(iObj) & ">" Else Err.Raise JSON_ERROR_INVALID_INPUT, "json", "Input is not a array or Collection or Dictionary" End If End If obj2json = o2jRekursive(iObj) obj2json = o2jUnicode2Mask(obj2json, iEncodeParams) 'If andB(iEncodeParams, jqmSingleQuote) Then obj2json = replace(obj2json, "\u0027", "\'") End Function '/** ' * Interner Stringersteller ' * @param Objekt ' * @param jsonEncodeParams Angabe über die Art der Anführungszeichen im JSON-String ' * @return String ' */ Private Function o2jRekursive(ByRef iObj As Variant) As String 'Array If IsArray(iObj) Then o2jRekursive = o2jArray(iObj) 'Collection ElseIf TypeName(iObj) = "Collection" Then o2jRekursive = o2jCollection(iObj) 'Dictionary ElseIf TypeName(iObj) = "Dictionary" Then o2jRekursive = o2jDict(iObj) ElseIf IsObject(iObj) And andB(o2jParams, jqmNoErrorForWrongType) Then o2jRekursive = "<" & TypeName(iObj) & ">" '[Key:]Value Else o2jRekursive = o2jValue(iObj) End If End Function '/** ' * get JSON-String from Collection ' * @param Collection ' * @param jsonEncodeParams Angabe über die Art der Anführungszeichen im JSON-String ' * @return String JSON-String ' */ Private Function o2jCollection(ByRef iCollection As Variant) As String Dim arr() As Variant: ReDim arr(1 To iCollection.count) Dim i As Long: For i = 1 To iCollection.count If IsObject(iCollection(i)) Then Set arr(i) = iCollection(i) Else arr(i) = iCollection(i) Next i o2jCollection = o2jArray(arr) If (o2jParams And jqmInternalArrayPrefix) Then o2jCollection = "#C" & Mid(o2jCollection, 3) End If End Function '/** ' * get JSON-String from Array ' * @param Array ' * @param jsonEncodeParams Angabe über die Art der Anführungszeichen im JSON-String ' * @return String JSON-String ' */ Private Function o2jArray(ByVal iArray As Variant) As String Dim i As Long: For i = LBound(iArray) To UBound(iArray) iArray(i) = o2jRekursive(iArray(i)) Next i If o2jParams And jqmForceObject Then o2jArray = "[" & join(iArray, ",") & "]" Else o2jArray = "[" & join(iArray, ",") & "]" End If If o2jParams And jqmInternalArrayPrefix Then o2jArray = "#A" & o2jArray End Function '/** ' * get JSON-String from Dictionary ' * @param Dictionary ' * @param jsonEncodeParams Angabe über die Art der Anführungszeichen im JSON-String ' * @return String JSON-String ' */ Private Function o2jDict(ByRef iDict As Variant) As String If iDict.count = 0 Then o2jDict = IIf(o2jParams And jqmForceObject, "{}", "") Exit Function End If Dim parts() As String: ReDim parts(iDict.count - 1) Dim keys() As Variant: keys = iDict.keys Dim items() As Variant: items = iDict.items Dim i As Long: For i = 0 To iDict.count - 1 parts(i) = o2jValue(keys(i)) & ":" & o2jRekursive(items(i)) Next i o2jDict = "{" & join(parts, ",") & "}" End Function '/** ' * Maskiert die Items und handelt die Spezialwerte ' * http://de.wikipedia.org/wiki/JavaScript_Object_Notation ' * @param String ' * @param jsonEncodeParams Angabe über die Art der Anführungszeichen im JSON-String ' * @return String JSON-String ' */ Private Function o2jValue(ByVal iVar As Variant) As String 'Null If IsNull(iVar) Then 'Null-Werte als null zurückgeben o2jValue = "null" 'Boolean ElseIf TypeName(iVar) = "Boolean" Then 'Boolen als true/false ausgeben o2jValue = LCase(CBool(iVar)) 'Date ElseIf IsDate(iVar) Then 'Datum If o2jRxTimeOnly.test(CStr(iVar)) Then o2jValue = format(iVar, obj2json_time_format) ElseIf (hour(iVar) + minute(iVar) + second(iVar)) = 0 Then o2jValue = format(iVar, obj2json_date_format) Else o2jValue = format(iVar, obj2json_timestamp_format) End If 'Char ElseIf Not IsNumeric(iVar) Then 'Texte als "t\\ext" ausgeben '\ zu \u005C wandeln o2jValue = replace(iVar, "\", C_UNICODE_BACKSLASH) 'weitere Spez-Charakters gemäss http://tools.ietf.org/html/rfc7159#section-7 If Not andB(o2jParams, jqmNoUnicode) Then o2jValue = unicodeSpezChars(o2jValue) '\u005C zu \\ wandeln If Not o2jParams And jqmReverseSolidusAsUnicode Then o2jValue = replace(o2jValue, C_UNICODE_BACKSLASH, "\\") End If o2jValue = stringDelemiter & o2jValue & stringDelemiter 'Number Else 'Zahlen normal ausgeben o2jValue = iVar End If End Function '------------------------------------------------------------------------------- ' JSON to Object '------------------------------------------------------------------------------- '/** ' * Parst ein JSON-String in Dictionaries und Collections oder Arrays ' * @param String JSON-String oder JSON-String mit Paramters [a,b,c], /[a,b,c]/d ' * @param jsonDecodeParams Einstellung, ob [...] als Array oder als Collection zurückgegeben wird ' * @param Variant Dasselbe wie der Return-Wert. Wenn amn json2obj() als sub() aufruft, muss man sich nicht darum kümmern, ob ein Array oder ein Object zurückkommt. ' * @return Variant Dictionary, Collection oder Array ' */ Public Function json2obj(ByVal iString As Variant, Optional ByVal iParams As jsonDecodeParams = jrtDefault, Optional ByRef oObj As Variant, Optional ByVal iCompareMode As CompareMethod = CompareMethod.DatabaseCompare) As Variant ' c jrtCollection = 2 ^ 1 'Als Collection ' a jrtArray = 2 ^ 2 'Als Array ' d jrtDictionary = 2 ^ 3 'Als Dictionary ' n jrtNotCastValue = 2 ^ 4 'cast der Values verhindern ' L jrtEmptyList = 2 ^ 5 'Angabe, ob bei einem Leeren String eine Collection/Array/Dictionary zurückgegeben werden soll ' D jrtEmptyDictionary = 2 ^ 7 'bei jrtEmptyList wird anhand von jrtDictionary etc. bestimmt was es sein soll. jrtDictionary jedoch parst nachher alles in ein Dictionary. DIeses Setting nur Empty ' S jrtSingle2List = 2 ^ 6 Static rxParseParam As Object: If rxParseParam Is Nothing Then Set rxParseParam = cRx("^(\/)(.*?)(?:\1([cadnLDS]+))$") If rxParseParam.test(iString) Then Dim pp As Object: Set pp = rxParseParam.execute(NZ(iString))(0) iString = pp.subMatches(1) Dim pstr As String: pstr = pp.subMatches(2) iParams = 0 If InStrB(pstr, "c") And Not andB(iParams, jrtCollection) Then iParams = iParams + jrtCollection If InStrB(pstr, "a") And Not andB(iParams, jrtArray) Then iParams = iParams + jrtArray If InStrB(pstr, "d") And Not andB(iParams, jrtDictionary) Then iParams = iParams + jrtDictionary If InStrB(pstr, "n") And Not andB(iParams, jrtNotCastValue) Then iParams = iParams + jrtNotCastValue If InStrB(pstr, "L") And Not andB(iParams, jrtEmptyList) Then iParams = iParams + jrtEmptyList If InStrB(pstr, "D") And Not andB(iParams, jrtEmptyDictionary) Then iParams = iParams + jrtEmptyDictionary If InStrB(pstr, "S") And Not andB(iParams, jrtSingle2List) Then iParams = iParams + jrtSingle2List End If j2oParams = iParams If j2oEmptyHandler(iString, json2obj) Then Exit Function Dim strr As String: strr = StrReverse(removeSpaces(iString)) Dim contents As Object: Set contents = CreateObject("scripting.Dictionary") Dim i As Integer 'Maskierte Zeichen []{}'"# in Unicode parsen Do While j2oRxMaskedChars.test(strr) 'strr = j2oRxMaskedChars.replace(strr, StrReverse(char2unicode(j2oRxMaskedChars.execute(strr)(0).subMatches(0)))) strr = j2oRxMaskedChars.replace(strr, StrReverse(j2oDictJsonSpezChars(StrReverse(j2oRxMaskedChars.execute(strr)(0).subMatches(0))))) Loop Dim str As String: str = StrReverse(strr) 'Alle []{}'"# innerhalb eines Strings in Unicode parsen If j2oRxStrings.test(str) Then Dim mc As Object: Set mc = j2oRxStrings.execute(str) For i = mc.count - 1 To 0 Step -1 Dim substr As String: substr = mc(i).subMatches(1) Do While j2oRxCharsInStringToUnicode.test(substr) substr = j2oRxCharsInStringToUnicode.replace(substr, CStr(char2unicode(j2oRxCharsInStringToUnicode.execute(substr)(0)))) Loop Dim dm As String: dm = mc(i).subMatches(0) str = replaceIndex(str, dm & substr & dm, mc(i).firstIndex, mc(i).Length) Next i End If i = 0 Do While j2oRxParseList.test(str) 'Key ermitteln Dim key As String: key = format(inc(i), "\&\#\#000\;") 'Ergibt den Key '&##002;' Dim sm As Object: Set sm = j2oRxParseList.execute(str)(0).subMatches 'Art der liste herausfinden Dim listType As jsonDecodeParams Select Case UCase(sm(0)) 'Mit IntenralPrefix Case "#A": listType = jrtArray Case "#C": listType = jrtCollection Case "#D": listType = jrtDictionary 'Anhand des Delemiters und der Settings. bei { ist es ein Dictionary, bei [ je nach Paramters ein Array oder eine Collection Case Else: listType = Switch( _ (j2oParams And jrtCollection), jrtCollection, _ sm(1) = "{", jrtDictionary, _ (j2oParams And jrtDictionary), jrtDictionary + jrtArray, _ True, jrtArray _ ) End Select 'Liste nach Type parsen Select Case listType Case jrtArray: contents.add key, j2oArray(contents, sm(2)) Case jrtCollection: contents.add key, j2oCollection(contents, sm(2)) Case jrtDictionary: contents.add key, j2oDict(contents, sm(2), iCompareMode) Case jrtDictionary + jrtArray: contents.add key, j2oArrayDict(contents, sm(2), iCompareMode) End Select 'Liste im JSON durch den Key ersetzen str = j2oRxParseList.replace(str, key) Loop 'Der Letzte Inhalt des contents entspricht der json2obj If key = "" And isEmpty(contents(key)) And contents.count = 1 And iParams And jrtSingle2List Then ref json2obj, json2obj("[" & iString & "]", iParams) Else ref json2obj, contents(key) End If ref oObj, json2obj End Function '/** ' * Handelt eine leere Eingabe ' * @param IN String 'Übergabestring aus json2obj() ' * @param OUT Variant 'Returnwert für json2obj() ' * @return Boolean 'Flag ob iString ein leerer String oder NULL ist ' */ Private Function j2oEmptyHandler(ByVal iString As Variant, ByRef oList As Variant) As Boolean j2oEmptyHandler = (trim(NZ(iString)) = Empty) 'Prüfen ob der String als leer gilt If Not j2oEmptyHandler Then Exit Function 'Wenn nicht, funktion verlassen. Rückgabewert = FALSE If j2oParams And jrtEmptyDictionary Then Set oList = CreateObject("scripting.Dictionary") Exit Function End If If j2oParams And jrtEmptyList Then If j2oParams And jrtDictionary Then Set oList = CreateObject("scripting.Dictionary") ElseIf j2oParams And jrtCollection Then Set oList = New Collection Else oList = emptyArrayVariant() End If End If End Function '/** ' * Wandelt ein JSON-String in ein Array ' * @param Dictionary Den Container der aktuellen Verschachtelungen ' * @param String Listenstring ' * @return Array ' */ Private Function j2oArray(ByRef iContents As Object, ByRef iListString As Variant) As Variant Dim list As Variant: list = Split(iListString, ",") Dim retArr() As Variant: ReDim retArr(UBound(list)) Dim k As Integer: For k = 0 To UBound(list) ref retArr(k), j2oValue(iContents, trim(list(k))) Next k j2oArray = retArr End Function '/** ' * Wandelt ein JSON-String in ein Array ' * @param Dictionary Den Container der aktuellen Verschachtelungen ' * @param String Listenstring ' * @return Array ' */ Private Function j2oArrayDict(ByRef iContents As Object, ByRef iListString As Variant, Optional ByVal iCompareMode As CompareMethod = CompareMethod.DatabaseCompare) As Variant Dim list As Variant: list = Split(iListString, ",") Set j2oArrayDict = CreateObject("scripting.Dictionary") j2oArrayDict.CompareMode = iCompareMode Dim k As Integer: For k = 0 To UBound(list) j2oArrayDict.add k, j2oValue(iContents, trim(list(k))) Next k End Function '/** ' * Wandelt ein JSON-String in eine Collection ' * @param Dictionary Den Container der aktuellen Verschachtelungen ' * @param String Listenstring ' * @return Collection ' */ Private Function j2oCollection(ByRef iContents As Object, ByRef iListString As Variant) As Object Dim list As Object: Set list = j2oDict(iContents, iListString) Set j2oCollection = New Collection If iListString = "" Then Exit Function Dim keys As Variant: keys = list.keys Dim k: For Each k In keys j2oCollection.add list(k), CStr(k) Next k End Function '/** ' * Wandelt ein JSON-String in ein Dictionary ' * @param Dictionary Den Container der aktuellen Verschachtelungen ' * @param String Listenstring ' * @return Dictionary ' */ Private Function j2oDict(ByRef iContents As Object, ByRef iListString As Variant, Optional ByVal iCompareMode As CompareMethod = CompareMethod.DatabaseCompare) As Object Set j2oDict = CreateObject("scripting.Dictionary") j2oDict.CompareMode = iCompareMode If iListString = "" Then Exit Function Dim list As Object: Set list = cDictAJson(Array(CStr(iListString))) Dim keys As Variant: keys = list.keys Dim k As Integer: For k = 0 To UBound(keys) j2oDict.add j2oValue(iContents, keys(k), True), j2oValue(iContents, list(keys(k))) Next k End Function '/** ' * Gibt ein Value zurück. Parst oder Castet den Wert ' * @param Dictionary Den Container ' * @param Variant Zu pasender Value ' * @param Boolean ' * @retrun Variant ' */ Private Function j2oValue(ByVal iContents As Object, ByVal iVar As Variant, Optional ByVal iFirstMatch As Boolean = False) As Variant If iContents.exists(iVar) Then 'Wenn iVar im Container exisitert ist es ein Key. Dann wird der Containerinhalt zurückgegeben If iFirstMatch Then ref j2oValue, iContents(iVar)(0) Else ref j2oValue, iContents(iVar) End If ElseIf j2oParams And jrtNotCastValue Then 'iVar ist ein Wert. Anahnd des Params jrtNotCastValue ist definiert, ob cValue ausgeführt werden soll j2oValue = j2oRxStrings.replace(unicodeDecode(iVar), "$2") 'unicodeDecode(iVar) Else ref j2oValue, iVar If Not IsObject(j2oValue) Then If j2oParseIsoDate(j2oValue) Then ref j2oValue, cVal(unicodeDecode(j2oValue)) End If If j2oRxStringsSingle.test(j2oValue) Then j2oValue = j2oRxStringsSingle.replace(j2oValue, "$2") j2oValue = unicodeDecode(j2oValue) End If j2oValue = cVal(j2oValue) End If End If End Function '/** ' * Parst das ISO-Datumsformat ' * ISO 8601 :standard: "2012-03-19T07:22Z". ' * @return Boolean ' */ Private Function j2oParseIsoDate(ByRef ioVar As Variant) As Boolean If trim(ioVar) = "" Then Exit Function If pJ2ORxDate Is Nothing Then Set pJ2ORxDate = cRx(json2obj_timestamp_pattern) If IsObject(ioVar) Or IsArray(ioVar) Or IsNull(ioVar) Then Exit Function j2oParseIsoDate = pJ2ORxDate.test(ioVar) If j2oParseIsoDate Then ioVar = pJ2ORxDate.replace(ioVar, json2obj_timestamp_replace) End Function '------------------------------------------------------------------------------- ' -- Public Properties '------------------------------------------------------------------------------- '/** ' * Das Format, in welchem ein reines Datum in den JSON geschrieben wird. ' * Standard: YYYY-MM-DD\T ' * @return String '*/ Public Property Get obj2json_date_format() As String If pDateFormat = Empty Then pDateFormat = C_OBJ2JSON_DATE_FORMAT_DEFAULT obj2json_date_format = pDateFormat End Property Public Property Let obj2json_date_format(ByVal iFormat As String) pDateFormat = iFormat End Property '/** ' * Das Format, in welchem eine reine Zeit in den JSON geschrieben wird. ' * Standard: HH:NN:SS\Z ' * @return String '*/ Public Property Get obj2json_time_format() As String If pTimeFormat = Empty Then pTimeFormat = C_OBJ2JSON_TIME_FORMAT_DEFAULT obj2json_time_format = pTimeFormat End Property Public Property Let obj2json_time_format(ByVal iFormat As String) pTimeFormat = iFormat End Property '/** ' * Das Format, in welchem ein reines Datum mit Zeit in den JSON geschrieben wird. ' * Standard: YYYY-MM-DD\THH:NN:SS\Z ' * @return String '*/ Public Property Get obj2json_timestamp_format() As String If pTimeStampFormat = Empty Then pTimeStampFormat = C_OBJ2JSON_TIMESTAMP_FORMAT_DEFAULT obj2json_timestamp_format = pTimeStampFormat End Property Public Property Let obj2json_timestamp_format(ByVal iFormat As String) pTimeStampFormat = iFormat End Property '/** ' * Pattern zum Auslesen eines JSON-Datums. ' * Schreibweise siehe http://wiki.yaslaw.info/doku.php/vba/cast/cregexp ' * Muss zusammen mit json2obj_timestamp_replace einen gültigen Datumsstring ergeben (isDate(), cDate()) ' * Standard: /^(?:(\d{4}-\d{2}-\d{2})T)?(?:(\d{2}:\d{2}:\d{2})Z)?$/i ' * @return String '*/ Public Property Get json2obj_timestamp_pattern() As String If pTimeStampTemplate = Empty Then pTimeStampTemplate = C_JSON2OBJ_TIMESTAMP_PATTERN json2obj_timestamp_pattern = pTimeStampTemplate End Property Public Property Let json2obj_timestamp_pattern(ByVal iPattern As String) pTimeStampTemplate = iPattern Set pJ2ORxDate = Nothing End Property '/** ' * Replace zum Auslesen eines JSON-Datums. ' * Muss zusammen mit json2obj_timestamp_pattern einen gültigen Datumsstring ergeben (isDate(), cDate()) ' * Standard: $1 $2 ' * @return String '*/ Public Property Get json2obj_timestamp_replace() As String If pTimeStampReplace = Empty Then pTimeStampReplace = C_JSON2OBJ_TIMESTAMP_REPLACE json2obj_timestamp_replace = pTimeStampReplace End Property Public Property Let json2obj_timestamp_replace(ByVal iReplace As String) pTimeStampReplace = iReplace End Property '------------------------------------------------------------------------------- ' -- Private Properties '------------------------------------------------------------------------------- '/** ' * Findet einen reinen Time-String ' * @retrun RegExp ' */ Private Property Get o2jRxTimeOnly() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^\d{2}:\d{2}:\d{2}$/i") Set o2jRxTimeOnly = rx End Property '/** ' * Ermittelt maskierte String und Datumsdelemiter ' * Da dieser RegExp innerhalb eines Loops mit replace() arbeitet, ist er nicht Global ' * @retrun RegExp ' */ Private Property Get j2oRxMaskedChars() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/(['""#\\\[\]trn]\\)/") Set j2oRxMaskedChars = rx End Property '/** ' * Chars, welche innerhalb eines Strings stehen. Diese müssen in Unicode gewandelt werden ' * @retrun RegExp ' */ Private Property Get j2oRxCharsInStringToUnicode() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/([\[\]\{\}'""#,:])/") Set j2oRxCharsInStringToUnicode = rx End Property '/** ' * Ermittelt Strings innerhlab eines JSON. '...' und "..." ' * @retrun RegExp ' */ Private Property Get j2oRxStrings() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/(['""])([^\1]*?)\1/g") Set j2oRxStrings = rx End Property '/** ' * Ermittelt Strings innerhlab eines JSON. '...' und "..." ' * @retrun RegExp ' */ Private Property Get j2oRxStringsSingle() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^(['""])([^\1]*?)\1$/g") Set j2oRxStringsSingle = rx End Property '/** ' * RegEx um die Listen {..} und [...] zu finden ' * @retrun RegExp ' */ Private Property Get j2oRxParseList() As Object Static rx As Object: If rx Is Nothing Then Set rx = cRx("/\s*(#A|#C|#D|)([\[\{])([^\[\{\]\}]*)[\]\}]/i") Set j2oRxParseList = rx End Property Private Function o2jUnicode2Mask(ByVal iString$, ByVal iEncodeParams As Long) As String Static rx As Object: If rx Is Nothing Then Set rx = cRx("/(\\u00(?:0D|0A|09|28|05B|05D|07B|07D|023|02C|03A|02))/i") o2jUnicode2Mask = iString If Not andB(iEncodeParams, jqmUnicodeInsteadOfMask) Then Do While rx.test(o2jUnicode2Mask) Dim m: Set m = rx.execute(o2jUnicode2Mask)(0) o2jUnicode2Mask = rx.replace(o2jUnicode2Mask, o2jDictJsonSpezChars(m.value)) Loop If andB(iEncodeParams, jqmSingleQuote) Then o2jUnicode2Mask = replace(o2jUnicode2Mask, "\u0027", "\'") Else o2jUnicode2Mask = replace(o2jUnicode2Mask, "\u0022", "\""") End If End If End Function Private Property Get o2jDictJsonSpezChars() As Object Static dict As Object If dict Is Nothing Then Set dict = CreateObject("scripting.Dictionary") dict.add "\u000A", "\n" 'new Line dict.add "\u000D", "\r" 'carige return dict.add "\u0009", "\t" 'Tab dict.add "\u0027", "\'" dict.add "\u0028", "\(" dict.add "\u005B", "\[" dict.add "\u005D", "\]" dict.add "\u007B", "\{" dict.add "\u007D", "\}" dict.add "\u0022", "\""" dict.add "\u0023", "\#" dict.add "\u002C", "\," dict.add "\u003A", "\:" dict.add "\u0029", "\)" End If Set o2jDictJsonSpezChars = dict End Property Private Property Get j2oDictJsonSpezChars() As Object Static dict As Object If dict Is Nothing Then Set dict = CreateObject("scripting.Dictionary") Dim keys: keys = o2jDictJsonSpezChars.keys Dim k: For Each k In keys dict.add o2jDictJsonSpezChars(k), k Next k End If Set j2oDictJsonSpezChars = dict End Property '------------------------------------------------------------------------------- ' -- Private Methodes '------------------------------------------------------------------------------- 'Entfernt tab,formfeed, return und new Line aus einem String Private Function removeSpaces(ByVal iString As String) As String Static rx As Object: If rx Is Nothing Then Set rx = cRx("/[\u0000\f\t\n\r]/g") removeSpaces = rx.replace(iString, "") End Function Private Function extractString(ByVal iString As String) As String Static rx As Object: If rx Is Nothing Then Set rx = cRx("/^([""'])?(.*)?\1$/") extractString = rx.replace(iString, "$2") 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 '/** ' * 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 'vbTab, vbLf, vbCr, vbFormFeed, ":", ",", """", "'" 'Sonderzeichen ausserhalb Ascii 32 bis 127 ersetzen. Leerzeichen nicht ersetzen (\u0020d). Dafür den aktive Delemiter 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 Or stringDelemiter <> lastQm Then Set rx = cRx("/(" & stringDelemiter & "|[^\u0021-\u007e\u0020d])/i") lastQm = stringDelemiter Do While rx.test(unicodeSpezChars) unicodeSpezChars = rx.replace(unicodeSpezChars, char2unicode(rx.execute(unicodeSpezChars)(0).subMatches(0))) Loop End Function '/** ' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück ' * @param String ' * @return String ' */ Private Function unicodeDecode(ByVal iString) As String unicodeDecode = iString Static rx As Object If rx Is Nothing Then Set rx = cRx("/\\u[0-9A-F]{4}/i") Do While rx.test(unicodeDecode) unicodeDecode = rx.replace(unicodeDecode, unicode2Char(rx.execute(unicodeDecode)(0))) Loop 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 Variant, Optional ByVal iLength As Integer = 1) As String replaceIndex = Left(iExpression, iIndex) & iReplace & Mid(iExpression, iIndex + iLength + 1) End Function '/** ' * Dito zu cDict(). Die Übergabe ist aber nicht ein ParamArray sondern ein Arry. ' * Spezielle ANpassung für json2Obj ' * Dieser Aufruf wird vor allem im Einsatz in anderen Funktionen verwendet ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cdic ' * V3.1.3 ' * @param Array ' * @return Dictionary ' */ Private Function cDictAJson(Optional ByRef iItems As Variant) As Object 'Cache RegExp um einSet-String zu zerlegen Static rxSetString As Object: If rxSetString Is Nothing Then Set rxSetString = cRx("/(?:\s*,\s*)?(?!\\)(|lluN|eslaf|eurt|(['""#](?![\\,])).+?\1(?!\\)|[\d\.]*|.*?)\s*(?:>=|[:=])\s*((['""](?!\\)).+?\4(?!\\)|(\](?!\\)).+?\[(?!\\)|[\w\s-]+\b)/ig") Static rxCharsInStringToUnicode As Object: If rxCharsInStringToUnicode Is Nothing Then Set rxCharsInStringToUnicode = cRx("/([\[\]\{\}'""=;,:])/") Static rxStrings As Object: If rxStrings Is Nothing Then Set rxStrings = cRx("/(['""#])([^\1]*?)\1/g") Set cDictAJson = CreateObject("scripting.Dictionary") Dim mc As Object Dim items() As Variant: items = CVar(iItems) Dim key As Variant, value As Variant Dim isList As Boolean If UBound(items) = -1 Then Exit Function 'Prüfen ob 2 Parametetrs übergeben wurden If UBound(items) = 1 Then 'Beide Parametrer sind Arrays -> Combine: Erster Array Keys, 2ter Values If IsArray(items(0)) And IsArray(items(1)) Then Dim keys() As Variant: keys = items(0) Dim values() As Variant: values = items(1) Dim delta As Long: delta = LBound(keys) - LBound(values) ReDim Preserve values(LBound(values) To UBound(keys) + delta) Dim i As Integer: For i = LBound(keys) To UBound(keys) If Not cDictAJson.exists(keys(i)) Then cDictAJson.add keys(i), values(i + delta) Next i Exit Function End If End If 'Alle Items durchackern Dim cnt As Integer: cnt = 0 Dim item As Variant: For Each item In items 'Dictionary If Not isList And TypeName(item) = "Dictionary" Then For Each key In item.keys If Not cDictAJson.exists(key) Then cDictAJson.add key, item.item(key) Next key 'einsamer Array ElseIf Not isList And IsArray(item) Then For key = LBound(item) To UBound(item) If Not cDictAJson.exists(key) Then cDictAJson.add key, item(key) Next key 'SetString ElseIf Not isList And Not IsArray(item) And Not IsObject(item) Then 'Alle []{}'"=;, innerhalb eines Strings in Unicode parsen If rxStrings.test(item) Then Set mc = rxStrings.execute(item) For i = mc.count - 1 To 0 Step -1 Dim substr As String: substr = mc(i).subMatches(1) Do While rxCharsInStringToUnicode.test(substr) substr = rxCharsInStringToUnicode.replace(substr, CStr(char2unicode(rxCharsInStringToUnicode.execute(substr)(0)))) Loop Dim dm As String: dm = mc(i).subMatches(0) item = replaceIndex(item, dm & substr & dm, mc(i).firstIndex, mc(i).Length) Next i End If If rxSetString.test(StrReverse(item)) Then Set mc = rxSetString.execute(StrReverse(item)) Dim k As Variant: For k = mc.count - 1 To 0 Step -1 key = extractString(unicodeDecode(StrReverse(mc(k).subMatches(2)))) 'value = extractString(unicodeDecode(StrReverse(mc(k).subMatches(0)))) value = unicodeDecode(StrReverse(mc(k).subMatches(0))) If Not cDictAJson.exists(key) Then cDictAJson.add key, value Next k Else GoTo default 'Zuerst wollte ich diesen GoTo nicht haben. Aber StrReverse() wirft ein Fehler wenn ein Objekt übergeben wird. Darum konnte der Test nicht im ElseIf durchgeführt werden. End If 'Alles andere geht in ein WertePaar. ElseIf cnt = 0 Or isList Then default: If cnt Mod 2 = 0 Then key = item ElseIf Not cDictAJson.exists(key) Then cDictAJson.add key, item End If isList = True End If cnt = cnt + 1 Next 'Falls es sich um eine nicht abgeschlossene Liste handelt 'JSON: Key als Nummer und KEY als Wert If isList And cnt Mod 2 <> 0 Then If Not cDictAJson.exists(key) Then cDictAJson.add key, key Else Dim idx As Integer: idx = 0 Do While cDictAJson.exists(idx) idx = idx + 1 Loop cDictAJson.add idx, key End If End If End Function '------------------------------------------------------------------------------- '-- LIBRARIES '------------------------------------------------------------------------------- '/** ' * PreIncrement ++i ' * Zählt i eins hoch und gibt den Wert zurück ' * V1.0.0 ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/increment ' * @param Number ' * @retrun Number ' */ Private Function inc(ByRef i As Variant) As Variant i = i + 1: inc = i End Function '/** ' * Version 1.3.0 ' * Es wird versucht, den Paramter in seine eigentlichen Typ zu wandeln. Gar mit Textausgaben oder parsen von SQL interessant ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cval ' * @example cVal("Null") -> Null, cVal("True") -> -1, cVal("time") -> 15:08:37 ' * @param Variant ' * @return Variant ' */ Private Function cVal(ByVal iValue As Variant) As Variant On Error Resume Next #If ms_product = C_ACCESS Then Set cVal = iValue: cVal = iValue: cVal = Eval(iValue) #Else Set cVal = iValue: cVal = iValue: cVal = CDbl(iValue): cVal = CLng(iValue): cVal = CInt(iValue) cVal = IIf(UCase(iValue) = "NULL", Null, cVal) #End If If IsDate(iValue) Then cVal = CDate(iValue) Select Case UCase(iValue) Case "EMPTY": cVal = Empty Case "NOTHING": Set cVal = Nothing Case "FALSE": cVal = False Case "TRUE": cVal = True End Select 'Falls der TExt einem reservierten Wort entspricht, fällt eval auf den Kopf. Darum direkt mappen If reservedWords.exists(UCase(iValue)) Then ref cVal, iValue End Function 'Für cVal angepasste Version, Folgende Items entfernt: False, True, Null, Nothing, Empty Private Property Get reservedWords() As Object 'https://bettersolutions.com/vba/syntax/keywords.htm um 'name' ergänzt Const C_RWORDS$ = "#If,#Else,#Else If,#End If,#Const,Alias,And,As,Base,Boolean,Byte,ByRef,ByVal," & _ "Call,Case,CBool,CByte,CCur,CDate,CDbl,CInt,CLng,CLngLng,CLngPtr,Compare,Const,CSng,CStr,Currency,Var," & _ "Database,Date,Declare,DefBool,DefByte,DefDate,DefDec,DefDouble,DefInt,DefLng,DefLngLng,DefLngPtr,DefObj,DefSng,DefStr,Dim,Do,Double," & _ "Each,Else,ElseIf,End,Enum,Erse,Error,Event,Exit,Explicit,For,Friend,Function,Get,Global,GoTo,If,IIf,Implements,Integer,Is," & _ "Let,LBound,Lib,Like,Long,LongLong,Loop,LSet,Me,Mod,Name,New,Next,Not,Object,On,Option,Optional,Or," & _ "ParamArray,Preserve,Private,Property,Public,RaiseEvent,ReDim,Resume,Return,RSet,Select,Set,Single,Static,Step,Stop,String,Sub," & _ "Text,ThenTo,Type,TypeOf,UBound,Until,Variant,Wend,While,With,WithEvents" Static dict As Object If dict Is Nothing Then Set dict = CreateObject("scripting.Dictionary") Dim rWordsArr$(): rWordsArr = Split(UCase(C_RWORDS), ",") Dim i&: For i = 0 To UBound(rWordsArr) dict.add trim(rWordsArr(i)), True Next i End If Set reservedWords = dict End Property '/** ' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht. ' * Diese Sub nimmt einem die Arbeit ab ' * oNode = iNode ' * @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 'Objekte als referenz übergeben Set oNode = iNode Else oNode = iNode End If End Sub '/** ' * 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 '/** ' * 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 #If IS_ACCESS = False Then '/** ' * Wandelt NULL in EMpty oder einen Defaultwert ' * @param Variant ' * @param Variant ' * @return Variant ' */ Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant If IsNull(iValue) Then NZ = iDefault Else NZ = iValue End If End Function #End If