Attribute VB_Name = "cast_cast" '------------------------------------------------------------------------------- 'File : cast_cast.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cast 'Environment : VBA 2010 + 'Version : 2.0.4 'Name : cast 'Author : Stefan Erb (ERS) 'History : 15.09.2014 - ERS - Creation ' 16.09.2014 - ERS - Cast auf String hinzugefügt ' 16.10.2016 - ERS - Diverse Klassen/Funktionen eingebunden (Siehe Settings) ' 22.12.2016 - ERS - Fehler Korrigiert, falls DateTime nicht eingebunden ist ' 16.07.2018 - ERS - isNMothing neu mit isMissing ' 04.09.2019 - ERS - Array() durch emptyArrayVariant() ersetzt '------------------------------------------------------------------------------- Option Explicit '------------------------------------------------------------------------------- ' -- ! SETTINGS ! '------------------------------------------------------------------------------- 'Da ich die cast-Funktion für mich geschrieben habe, habe ich sie weiter angepasst. 'Ich habe bereits einige Codes, die mir hilfreich sind Mit den Settings kann ein/ausgeschaltet werden, was im Projekt vorhanden ist 'Das Interface IFormattable ist in diesem Projekt vorhanden 'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/classes/iformattable #Const IFormattable_exists = False 'Meine DateTime Klasse ist im Projekt enthalten 'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/classes/date/index #Const DateTime_exists = False 'meine Iteratorklasse exisitert 'Bei einem Iterator-Objekt wird das source-Property geparst 'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/classes/iterator/index #Const Iterator_exists = False 'meine Json-Library 'Arrays, Dictionaries und Collection werden als Json-String ausgegeben 'http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/json #Const json_exists = False '------------------------------------------------------------------------------- ' -- Public members '------------------------------------------------------------------------------- Public Enum cReturnClass rcDefault = 0 #If DateTime_exists Then rcDateTime = 1 #End If #If Iterator_exists Then rcIterator = 2 #End If rcDictionary = 5 End Enum Public Enum cParams ecNone = 0 '0 ecOnErrorDefault = 2 ^ 0 '1 Bei einem Fehler den Standard 0/Empty/Leer ausgeben ecTrim = 2 ^ 1 '2 Text trimmen #If json_exists Then ecListNotAsJson = 2 ^ 10 '1024 Falls json installiert ist, diesen trotzdem nicht anwenden #End If 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() '------------------------------------------------------------------------------- ' -- Public methodes '------------------------------------------------------------------------------- '/** ' * Wandelt einen String wenn möglich in das angegebene Format um ' * @param VbVarType ' * @param Variant ' * @param cParams : Steuerparamters ' * @param String : ist das Zeil vbArray, dund die Quelle ein String, dann kann mittels des Delimiters der String geparst werden ' * @return Variant ' */ #If json_exists = True Then Public Function cast( _ ByVal iReturnVarType As VbVarType, _ ByRef iVar As Variant, _ Optional ByVal iParams As cParams = ecNone, _ Optional ByVal iDelimiter As String = ",", _ Optional ByVal iReturnClass As cReturnClass = rcDefault, _ Optional ByVal iEncodeParams As jsonEncodeParams = jqmDefault _ ) As Variant Dim extraParams As Long: extraParams = iEncodeParams #Else 'Der Dummy-Paramter ist nur dazu da, damit der Aufruf kompatibel bleibt Public Function cast( _ ByVal iReturnVarType As VbVarType, _ ByRef iVar As Variant, _ Optional ByVal iParams As cParams = ecNone, _ Optional ByVal iDelimiter As String = ",", _ Optional ByVal iReturnClass As cReturnClass = rcDefault, _ Optional ByVal iDummy As Byte _ ) As Variant Dim extraParams As Long: extraParams = 0 #End If On Error GoTo Err_Handler Dim flag As Boolean: flag = castObject(cast, iReturnVarType, iVar, iParams, iDelimiter, iReturnClass, extraParams) If Not flag Then flag = castRaw(cast, iReturnVarType, iVar, iParams, iDelimiter, iReturnClass, extraParams) If Not flag Then flag = castDefault(cast, iReturnVarType, iParams) If Not flag And Not andB(iParams, ecOnErrorDefault) Then Err.Raise 13 'Type mismatch Exit_Handler: Exit Function Err_Handler: Err.Raise Err.Number, Err.source, Err.Description, Err.HelpFile, Err.HelpContext End Function '------------------------------------------------------------------------------- ' -- Private methodes '------------------------------------------------------------------------------- '/** ' * Wandelt Grundtypen ' * @param Variant OUT ' * @param VbVarType ' * @param Variant ' * @param cParams : Steuerparamters ' * @param String : ist das Zeil vbArray, dund die Quelle ein String, dann kann mittels des Delimiters der String geparst werden ' * @return Boolean ' */ Private Function castRaw( _ ByRef ocast As Variant, _ ByVal iReturnVarType As VbVarType, _ ByRef iVar As Variant, _ ByVal iParams As cParams, _ ByVal iDelimiter As String, _ ByVal iReturnClass As cReturnClass, _ ByVal iExtraParams As Long _ ) As Boolean Dim retVal As Variant Dim subVarType As VbVarType Dim i As Long On Error GoTo Err_Handler castRaw = True If andB(iReturnVarType, vbArray) Then subVarType = iReturnVarType - vbArray iReturnVarType = vbArray End If Select Case iReturnVarType Case vbNull, vbEmpty '1, 0 If Not isNothing(iVar) Then Err.Raise 13 'Type mismatch retVal = Choose(iReturnVarType + 1, Empty, Null) Case vbObject, vbDataObject: '9 If isNothing(iVar) Then Set retVal = Nothing Else Select Case iReturnClass Case rcDictionary: Set retVal = CreateObject("scripting.Dictionary") retVal.add 0, IIf(andB(iParams, ecTrim), Trim(iVar), iVar) #If DateTime_exists Then Case rcDateTime: Set retVal = DateTime(cast(vbDate, iVar, iParams)) #End If #If Iterator_exists Then Case rcIterator: Set retVal = Iterator.instance(cast(vbArray, iVar, iParams)) #End If End Select End If Case vbArray: '8192 If IsArray(iVar) Then retVal = iVar ElseIf varType(iVar) = vbString Then #If json_exists Then retVal = json2obj(iVar, jrtArray) If Not IsArray(retVal) Then retVal = Split(iVar, iDelimiter) #Else retVal = Split(iVar, iDelimiter) #End If Else retVal = Array(iVar) End If If subVarType <> 0 Then For i = LBound(retVal) To UBound(retVal) retVal(i) = cast(subVarType, retVal(i), iParams, iDelimiter, iReturnClass, iExtraParams) Next i End If Case vbInteger: retVal = CInt(NZ(iVar)) '2 Case vbLong: retVal = CLng(NZ(iVar)) '3 Case vbSingle: retVal = CSng(NZ(iVar)) '4 Case vbDouble: retVal = CDbl(NZ(iVar)) '5 Case vbCurrency: retVal = CCur(NZ(iVar)) '6 Case vbDate: retVal = CDate(NZ(iVar)) '7 Case vbString: If IsArray(iVar) Then retVal = Join(iVar, iDelimiter) #If json_exists Then If Not andB(iParams, ecListNotAsJson) Then retVal = obj2json(iVar, iExtraParams) #End If Else retVal = CStr(NZ(iVar)) '8 If andB(iParams, ecTrim) Then retVal = Trim(retVal) End If Case vbError: '10 Case vbBoolean: retVal = CBool(NZ(iVar)) '11 Case vbVariant '12 Case vbDecimal: retVal = CDec(NZ(iVar)) '14 Case vbByte: retVal = CByte(NZ(iVar)) '17 Case Else: retVal = iVar: castRaw = False End Select ref ocast, retVal Exit Function Err_Handler: castRaw = False Exit Function Resume End Function '/** ' * Wandelt Objekte ' * @param Variant OUT ' * @param VbVarType ' * @param Variant ' * @param cParams : Steuerparamters ' * @param String : ist das Zeil vbArray, dund die Quelle ein String, dann kann mittels des Delimiters der String geparst werden ' * @return Boolean ' */ Private Function castObject( _ ByRef ocast As Variant, _ ByVal iReturnVarType As VbVarType, _ ByRef iVar As Variant, _ ByVal iParams As cParams, _ ByVal iDelimiter As String, _ ByVal iReturnClass As cReturnClass, _ ByVal iExtraParams As Long _ ) As Boolean Dim retVal If Not IsObject(iVar) Then Exit Function Set retVal = iVar: castObject = False Dim rawData As Variant Dim haveRawData As Boolean Select Case TypeName(iVar) #If DateTime_exists Then Case "DateTime": rawData = iVar.timeStamp haveRawData = True #End If #If Iterator_exists Then 'Wenn das Objekt ein Iterator ist, die cast-Methode auf das source-Property anwenden Case "Iterator": retVal = cast(iReturnVarType, iVar.source, iParams, iDelimiter, iReturnClass, iExtraParams) GoTo Exit_False #End If Case Else #If IFormattable_exists Then 'Falls es sich um ein Objekt mit dem Interface IFormattable handelt, die toString() Methode des Objektes anwenden On Error Resume Next Dim ft As IFormattable: Set ft = iVar rawData = IFormattable.cast(iVar).toString haveRawData = (Err.Number = 0) Err.clear On Error GoTo 0 #End If End Select Select Case iReturnVarType Case vbNull, vbEmpty If Not isNothing(iVar) Then Err.Raise 13 'Type mismatch retVal = Choose(iReturnVarType + 1, Empty, Null) GoTo Exit_True Case vbObject: On Error Resume Next Select Case iReturnClass Case rcDictionary: ' Set retVal = CreateObject("scripting.Dictionary") ' retVal.add 0, IIf(andB(iParams, ecTrim), Trim(iVar), iVar) #If DateTime_exists Then Case rcDateTime: Set retVal = DateTime(iVar) #End If #If Iterator_exists Then Case rcIterator: Set retVal = Iterator.instance(iVar) #End If Case rcDefault: Set retVal = iVar End Select On Error GoTo 0 If Err.Number <> 0 Then GoTo Exit_True Err.clear GoTo Exit_False Case vbArray: Select Case TypeName(iVar) Case "Dictionary": retVal = iVar.items Case "Collection": Dim a() As Variant: ReDim a(1 To iVar.count) Dim i As Integer: For i = 1 To iVar.count: a(i) = iVar(i): Next i retVal = a GoTo Exit_True Case Else End Select Case vbString: If haveRawData Then GoTo Exit_False #If json_exists Then 'Dictionary, Array oder Collection in ein Json wandeln If Not andB(iParams, ecListNotAsJson) Then Select Case TypeName(iVar) Case "Dictionary", "Collection": retVal = obj2json(iVar, iExtraParams) GoTo Exit_True End Select End If #End If 'Versuchen ein Array herauszulösen und diesen mit join zusammensetzen Dim arr() As Variant castObject = castObject(arr, vbArray, iVar, iParams, iDelimiter, iReturnClass, iExtraParams) If castObject Then castObject = castRaw(retVal, iReturnVarType, arr, iParams, iDelimiter, iReturnClass, iExtraParams) If castObject Then GoTo Exit_True Case Else: End Select Exit_False: If haveRawData Then ref retVal, cast(iReturnVarType, rawData, iParams, iDelimiter, iReturnClass, iExtraParams) GoTo Exit_True End If castObject = False Exit Function Exit_True: ref ocast, retVal castObject = True End Function '/** ' * Gibt die Standardwerte zurück ' * @param Variant RetValue ' * @param VbVarType ' * @param cParams : Steuerparamters ' * @return Boolean ' */ Private Function castDefault( _ ByRef ocast As Variant, _ ByVal iReturnVarType As VbVarType, _ ByVal iParams As cParams _ ) As Boolean If Not andB(iParams, ecOnErrorDefault) Then Exit Function castDefault = True Select Case iReturnVarType Case vbNull: ocast = Null '1 Case vbEmpty: ocast = Empty '0 Case vbObject: Set ocast = Nothing '9 Case vbDataObject: Set ocast = Nothing '13 Case vbArray: ocast = emptyArrayVariant '8192 Case vbInteger: ocast = CInt(0) '2 Case vbLong: ocast = CLng(0) '3 Case vbSingle: ocast = CSng(0) '4 Case vbDouble: ocast = CDbl(0) '5 Case vbCurrency: ocast = CCur(0) '6 Case vbDate: ocast = CDate(0) '7 Case vbString: ocast = Empty '8 Case vbError: castDefault = False '10 Case vbBoolean: ocast = False '11 Case vbVariant: ocast = Null '12 Case vbDecimal: ocast = CDec(0) '14 Case vbByte: ocast = CByte(0) '17 Case Else: ocast = Null End Select End Function '------------------------------------------------------------------------------- '--- LIBRARIES for cast '------------------------------------------------------------------------------- '/** ' * 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 '/** ' * Bei einer Variablenübergabe muss immer unterscheiden werden, ob es ein Objekt ist oder nicht. ' * Diese Sub nimmt einem die Arbeit ab ' * ref(oNode, iNode) ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/ref ' * @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: Exit Sub oNode = iNode End Sub '/** ' * Prüft, ob eine Variable Null, Empty, Nothing, Leerstring, leerer Array etc ist ' * ' * boolean = isNothing(object) ' * boolean = isNothing(vaule) ' * ' * @param Variant Variable die geprüft werden soll ' * @return Boolean ' */ Private Function isNothing(ByRef iValue As Variant) As Boolean isNothing = True Select Case TypeName(iValue) Case "Nothing", "Empty", "Null": Exit Function Case "Collection", "Dictionary": If iValue.count = 0 Then Exit Function Case "String": If Len(Trim(iValue)) = 0 Then Exit Function Case "Iterator": If Not iValue.isInitialized Then Exit Function '//TODO: weitere Spezialfälle Case Else: If IsArray(iValue) And IsMissing(iValue) Then Exit Function End Select isNothing = False End Function