cValue versucht einen String in ein Nativetyp zu casten.
Die Funktion wird zum Beispiel in [VBA] cDict() verwendet.
Download cast_cvalue.bas (V-1.3.0)
Ich habe 2 Versionen. cValue() ist ein ausführlicher, lesbarer Code der sich gut eignet um als eigenständige Funktion verwendet zu werden.
cV() ist auf das nötigste gekürzt und gestutzt. Sie hat die gleiche Funktionalität wir cValue(), ist jedoch vom Code her viel kompakter. Ich verwende vV() in verschiedenen anderen Funktionen.
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 'Ist die Zahl mit Delemiter umgeben, wird sie als String zurpückgegeben d cValue("'123'") <String> '123'
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. Als delemited Text gelten die drei folgenden Pattern: '..', "..", [..] 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'
Variant = cV(Variant [,flags])
Public Function cV( ByVal iValue As Variant, Optional ByVal iFlags As String ) As Variant
iFLags ist ein String, der das Verhalten cV() steuert. Die Flags sind3 Buchstaben de kombiniert werden können.
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().
'String zu Zahl d cV("1234.5") <Date> 01.05.1234 'Text Null d cV("NULL") <String> 'NULL' 'Text Null intepretieren d cV("NULL", "n") <Null> 'Leerer String d cV("") <Empty> 'Empty als Null zurückgeben d cV("", "e") <Null> 'Boolean als Wert d cV("TRUE") <String> 'TRUE' 'Boolean parsen d cV("TRUE", "b") <Boolean> True 'Kombioniert. Nicht alle Flags kommen unbedigt zum tragen ' Der String ist mit ' Als Deleimiter mitgeliefert d cV("'NULL'", "nd") <String> 'NULL'
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
'/** ' * 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