cValue versucht einen String in ein Nativetyp zu casten.

Download cast_cvalue.bas (V-1.0.0)

Variant = cValue(String [,cvHandling])

Public Function cValue(
    ByVal iString As String, 
    Optional ByVal iHandling As cvHandling
) As Variant

Public 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
End Enum

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

=

'Ein Integer asl Text -> Integer
d cValue("12345")
<Integer> 12345
 
'Wenn die Zahlen grösser sind, wird daraus ein Long, bzw. ein Decimal
d cValue("1234567890")
<Long> 1234567890
 
d cValue("12345678901234567890")
<Decimal> 12345678901234567890
 
'Dito für eine Gleitkommazahl -> Double
d cValue("123.45")
<Double> 123.45

Es wird mit cDate geparst. Dieses kann sich Systemabhängig anders verhalten

'Datum ohne Delemiter
d cValue("25/1/2014")
<Date> 25.01.2014
 
'Datum mit Delemiter
d cValue("#1-25-2014#")
<Date> 25.01.2014

'Ein Text ohne Delemiter
d cValue("ABC")
<String> 'ABC'
 
'Ein Text mit Delemiter
d cValue("'abc'")
<String> 'abc'

'Leerer Text
d cValue("")
<String> ''
 
'Leerer Text mit dem Flag, diesen als Null zu werten
d cValue("", cvhEmptyAsNull)
<Null> 
 
'Der Text Null
d cValue("Null")
<String> 'Null'
 
'Der Text Null mit dem Flag, diesen als Null zu werten
d cValue("Null", cvhNullTextAsNull)
<Null> 
 
'Der Text Null in Delemiter mit dem Flag, diesen als Null zu werten
d cValue("'Null'", cvhNullTextAsNull)
<String> 'Null'

cast_cvalue.bas

Attribute VB_Name = "cast_cValue"
'-------------------------------------------------------------------------------
'File         : cast_cValue.bas
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cvalue
'Environment  : VBA 2010 +
'Version      : 1.3.1
'Name         : cValue
'Author       : Stefan Erb (ERS)
'History      : 19.11.2014 - ERS - Creation
'               05.12.2014 - ERS - Nicht wirklich eine neue Version. cV() hinzugefügt
'               06.01.2015 - ERS - Kleine Logikfehler in cV ausgemerzt. "d" ist jetzt analog zu cvhNotRemoveDelemiter
'               31.08.2015 - ERS - Parameter cvhParseBooleanString (analog zu B in cV) in cValue hinzugefügt
'               19.10.2015 - ERS - in cValue den Input auf Variant gewechselt. Alles was kein String ist, wird nur durchgereicht
'               19.04.2017 - ERS - cValue, neue Version
'-------------------------------------------------------------------------------
Option Explicit
 
Public 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
    cvhParseBooleanString = 2 ^ 2
    cvhNotRemoveDelemiter = 2 ^ 3   'Bei Strings werden normalerweise ' und " entefernt. Mit diesem Parameter nicht.
End Enum
 
'/**
' * Castet ein String in was auch immer (Integer, Long, Date etc.)
' * Datum in ## oder Strings in ' und " können geparst werden
' * @param  String
' * @param  cvHandling  Flag zur Handhabung verschiedener Spezialfällen.
' * @return Varaint
' */
Public Function cValue(ByVal iValue As Variant, Optional ByVal iHandling As cvHandling) As Variant
    Static rxDateString As Object
    Static rxDelemitedString As Object
 
    'Den Datentyp über das Ausschlussverfahren ermitteln
    On Error Resume Next
 
    'iValue ist kein String (vbString=8). Dann wird der Type 1:1 zurückgegeben
    If Not varType(iValue) = vbString Then cValue = iValue: Exit Function
 
    Dim value As String: value = CStr(iValue)
 
    If iHandling And cvhNullTextAsNull And UCase(value) = "NULL" Then
        cValue = Null
        Exit Function
    End If
    If iHandling And cvhEmptyAsNull And value = Empty Then
        cValue = Null
        Exit Function
    End If
 
    'Nummern
    'Ein Cast machen und vergleichen ob der Wert gleich geblieben ist. Wenn ja, sind wir fündig geworden
    If IsNumeric(value) Then
        cValue = CByte(value):    If cValue = value Then Exit Function
        cValue = CInt(value):     If cValue = value Then Exit Function
        cValue = CLng(value):     If cValue = value Then Exit Function
        cValue = CDbl(value):     If cValue = value Then Exit Function
        cValue = CDec(value):     Exit Function
    End If
    Err.clear
 
    'Boolean
    If iHandling And cvhParseBooleanString = cvhParseBooleanString Then
        cValue = CBool(value):    If Err.number = 0 Then Exit Function
    End If
 
    'Datum
    'Normales Datum
    If IsDate(value) Then
        cValue = CDate(value)
        Exit Function
    End If
 
    'Datum in # Delemiter
    If rxDateString Is Nothing Then Set rxDateString = cRx("/^#(.*)#$/")
    If rxDateString.test(value) Then
        cValue = CDate(rxDateString.execute(value)(0).subMatches(0))
        Exit Function
    End If
 
    'String in Delemiter
    If Not iHandling And cvhNotRemoveDelemiter Then
        If rxDelemitedString Is Nothing Then Set rxDelemitedString = cRx("/^[#""'\[](.*)([""'#\]])$/") '0: String ohne Delemiter, 1: End-Delemiter: '," oder ]
        If rxDelemitedString.test(value) Then
            Dim sm As Object: Set sm = rxDelemitedString.execute(value)(0).subMatches
            cValue = Replace(sm(0), "\" & sm(1), sm(1))
            Exit Function
        End If
    End If
    'String 1 zu 1 zurückgeben
    cValue = value
    On Error GoTo 0
End Function
 
'/**
' * 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
 
 
'---------------------------------------
' Die folgende Version cV() verwende ich als Library in anderen Funktion.
' Sie entspricht der Version mit den Modifier im String.
 
'/**
' * Dies ist die Minimalversion von cValue (V1.3.0): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cvalue
' * @example    myDict.Add(1, cV("True", "b"))
' * @param      Variant     Wert der geparst wird
' * @param      String      Flag ('nebd')
' *     n: Der Text Null ohne Delemiter wird als Wert Null intepretiert:    "NULL" -> Null
' *     e: Ein leerer String wird als Null intepretiert,                    "" -> Null
' *     b: Boolean-Text wird als Boolean intepretiert                       "True" -> True (Boolean)
' *     d: Bei Delemited Strings den Delemiter nicht entfernen. ' oder " gelten als Delemiter: "'Hans'" -> Hans
' * @return     Variant
' */
Public Function cV(ByVal iValue As Variant, Optional ByVal iFlags As String) As Variant
    On Error Resume Next: If IsNull(iValue) Then cV = Null: Exit Function
    If Not varType(iValue) = 8 Then cV = iValue: Exit Function
    Static rxDa As Object, rxDs As Object: Dim sm As Object, str As String, flg As String:  str = CStr(iValue): flg = UCase(iFlags)
    If UCase(str) = "NULL" And InStr(flg, "N") Then cV = Null: Exit Function
    If iValue = Empty And CBool(InStr(flg, "E")) Then cV = Null: Exit Function
    cV = CByte(str):    If cV = str Then Exit Function
    cV = CInt(str):     If cV = str Then Exit Function
    cV = CLng(str):     If cV = str Then Exit Function
    cV = CDbl(str):     If cV = str Then Exit Function
    cV = CDec(str):     If cV = str Then Exit Function
    If IsDate(str) Then cV = CDate(str): Exit Function
    Err.clear: If InStr(flg, "B") Then cV = CBool(str):   If Err.number = 0 Then Exit Function
    If rxDa Is Nothing Then Set rxDa = CreateObject("VBScript.RegExp"): rxDa.pattern = "^#(.*)#$"
    If rxDa.test(str) Then cV = CDate(rxDa.execute(str)(0).subMatches(0)):  Exit Function
    If InStr(flg, "D") = 0 Then cV = iValue: Exit Function
    If rxDs Is Nothing Then Set rxDs = CreateObject("VBScript.RegExp"): rxDs.pattern = "^[#""'\[](.*)([""'#\]])$"
    If rxDs.test(str) Then Set sm = rxDs.execute(str)(0).subMatches: cV = Replace(sm(0), "\" & sm(1), sm(1)):  Exit Function
    cV = iValue
End Function