Eine Funktion die anhand der VarTypes versucht ein Wert zu casten. Diese Funktion ist nicht für Objekte geeignet.

Download cast_cast.bas (V-2.0.1)

boolean = cast(vbVarType, value [,Strong])

Public Function cast( _
        ByVal iType As VbVarType, _
        ByVal iVar As Variant, _
        Optional ByVal iStrong As Boolean = False _
) As Variant

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r()

d cast(vbInteger, "123.45")
<Integer> 123
 
'Versuch misslungen. Der Originalwert wird zurückgehen
d cast(vbInteger, "ABC")
<String> 'ABC'
 
'Dasselbe aber mit Strong
d cast(vbInteger, "ABC", true)
--> Verursacht einen Error 13 Type mismatch
 
'0, leerer String, Empty und Null können zu Null oder Empty konvertiert werden
d cast(vbNull, 0)
<Null> 
d cast(vbEmpty, NULL)
<Empty> 
 
'Boolean sind ebenfalls möglich
d cast(vbBoolean, 1)
<Boolean> True
 
'Ein einzelner Wert in ein Array wandeln
d cast(vbArray, 12)
<Variant()>  (
    [0] => <Integer> 12
)
 
'Ein Array in ein Array wandeln
d cast(vbArray, array(11, 12))
<Variant()>  (
    [0] => <Integer> 11
    [1] => <Integer> 12
)
 
'cast() führt auch zusätzlich ein NZ() aus
d cast(vbInteger, Null)
<Integer> 0

cast_cast.bas

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