Eine Sammlung von diversen Cast-Funktionen

VBA bietet beschränkte möglichkeiten zum Casten von Variablen. So muss man jedesmal, wenn man mit einem Variant arbeiten muss, diesen zuerst mit NZ parsen. Auch das Extrahieren von Zahlen innerhalb von Texten müssen jedesmal von Hand aus programmiert werden.

Darum habe ich mir eigene Cast-Funktionen erstellt. Um die Performance nicht allzufest in die Knie zu zwingen, wird zuerst versucht mittels Standart-VBA Befehlen die Zahl herauszulösen. Erst wenn das nicht geht, kommt RegExp in den Einsatz.

Die Cast-Funktionen greiffen auf andere Funktionen zu, die ich bereits erstellt habe.

Für die Nummer-Cast-Funktionen verwende ich rx_like und rx_choose aus [VBA] RegExp Functions mit Cache

Für castDate() wird die Funktion [VBA] strToDate() verwendet

[VBA] print_r() wird nur für die Beispiele gebraucht. Diese Funktion wird im Einsatz nicht gebraucht

Bisher sind die folgenden Funktionen umgesetzt

• castDbl() Castet in ein Double
• castInt() in ein Integer
• castLng() in ein Long(Integer)
• castDate() in ein Date
• castStr() in ein String

Diese Definition ist für die anderen Nummer Cast-Funktionen etwa gleich

Public Function castDbl( _
        ByRef iVar As Variant, _
        Optional ByVal iMatchIndex As Integer = 1, _
        Optional ByVal iDefaultValue As Double = 0 _
) As Double

• iVar Wert der gecastet werden soll
• iMatchIndex Bei einem String mit mehreren Zahlen ist dies der Index, welche Zahl genommen werden soll
• iDefaultValue Wert, welcher im Fehlerfall zurückgegeben werden soll

Ein Datum. Im Fall von Null den Defualt-Wert. Wenn bei einem Text keine Zahl rin ist, wird ebenfalls der Default_wert zurückgegeben

' Normaler Cast
print_r castDbl(" 123.45")
<Double> 123.45
 
'Casten von Null
print_r castDbl(Null)
<Double> 0
 
'Wieder NUll, aber als Standart-Wert -1
print_r castDbl(Null,,-1)
<Double> -1
 
'Casten des ersten Wertes aus einem Text
print_r castDbl("Hans kauft 12 Eier zu 3.45 Franken")
<Double> 12
 
'Ein String ohne Zahlen, jedoch mit einem Standart-Wert
print_r castDbl("Hans kauft Eier",,24)
<Double> 24
 
'Casten des 2ten Wertes aus demselben Text
print_r castDbl("Hans kauft 12 Eier zu 3.45 Franken", 2)
<Double> 3.45
 
'Und noch 2 Beispiele, wenn die übergeben Variable ein Objekt ist
print_r castDbl(New FileSystemObject)
<Double> 0
print_r castDbl(New FileSystemObject, , -1)
<Double> -1

Der castStr() ist eigentlich nicht viel mehr als ein cStr() mit nz() kombiniert

Public Function castStr( _
        ByRef iVar As Variant, _
        Optional ByVal iDefaultValue As String = vbNullString _
) As String

• iVar Wert der gecastet werden soll
• iDefaultValue Wert, welcher im Fehlerfall zurückgegeben werden soll

Ein String. Fall von Null, den Default-Wert

'Eine Zahl zu einem String
print_r castStr(12.5)
<String> '12.5'
 
'Ein Datum
print_r castStr(Now)
<String> '06.01.2014 14:21:44'
 
'Null
print_r castStr(Null)
<String> ''
 
print_r castStr(Null, "EMPTY")
<String> 'EMPTY'

Diese Funktion verwendet eine Kombination zwischen strToDate() und nz()

Public Function castDate( _
        ByRef iVar As Variant, _
        Optional ByVal iFormat As String = vbNullString, _
        Optional ByVal iDefaultValue As Date = 0, _
        Optional ByVal iTruncToDate As Boolean = True _
) As Date

• iVar Wert der gecastet werden soll
• iFormat Formatierung von iVar gem. [VBA] strToDate()
• iDefaultValue Wert, welcher im Fehlerfall zurückgegeben werden soll
• iTruncToDate FLag, ob die Uhrzeit abgeschnitten werden soll

Ein Datum. Wenn iVar kein gültiges Datum ergibt, dann wird iDefaultValue zurückgegen. Wenn Dieser Wert 0 ist, wird das aktuelle Datum zurückgegeben

' Einfacher Datumsstring
print_r castDate("6.1.14")
<Date> 06.01.2014
 
'Null -> Sysdate ohne Uhrzeit
print_r castDate(Null)
<Date> 06.01.2014
 
'Null -> Sysdate mit Uhrzeit
print_r castDate(ivar:= Null, iTruncToDate := false)
<Date> 06.01.2014 14:15:45
 
'String in einem anderen Datumsformat
print_r castDate("20140106", "yyyymmdd")
<Date> 06.01.2014
 
'Datum
print_r castDate(Now)
<Date> 06.01.2014
print_r castDate(Now,,,False)
<Date> 06.01.2014 14:38:36

Cast.bas

'-------------------------------------------------------------------------------
'File         : Cast
'               Copyright mpl by ERB software
'               All rights reserved
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/cast
'Environment  : VBA 2007 +
'Version      : 1.1
'Name         : Cast
'Author       : Stefan Erb (ERS)
'History      : 31.12.2013 - ERS - Creation
'               06.01.2014 - ERS - Funktionen castStr() und castDate() hinzugefügt
'Requiered    : Rx-Functions:   http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/rx/index
'               strToDate():    http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/strtodate
'-------------------------------------------------------------------------------
Option Explicit
 
'/**
' * Pattern um ein Double in einem String zu finden
'*/
Private Const C_NUM_PATTERN As String = "\d+\.?\d*"
 
'/**
' * Die Reihenfolge der Cast-Versuche
' */
Private Enum castTrySteps
    tryVBACast = 0      'Casten über die VBA-Eigenen Funktionen
    tryRegEx = 1        'Casten über Reguläre Ausdrüke
    setDefault = 2      'Setze den Default-Wert
End Enum
 
'/**
' * Castet Irgendwas zu einem String
' * Eigentlich macht diese Funktioen  nicht viel mehr als ein NZ() und ein cStr()
' * @param  Variant     Wert der gecastet werden soll
' * @param  String      Optional: Wert, welcher im Fehlerfall zurückgegeben werden soll
' * @return String
' */
Public Function castStr( _
        ByRef iVar As Variant, _
        Optional ByVal iDefaultValue As String = vbNullString _
) As String
On Error GoTo ERR_H
 
    'Zuerst mit den VB-Funktionen versuchen
    castStr = CStr(Nz(iVar, iDefaultValue))
    Exit Function
 
ERR_H:
    castStr = iDefaultValue
End Function
 
'/**
' * Castet Irgendwas zu einem Datum
' * Requiered:  strToDate http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/strtodate
' * @param  Variant     Wert der gecastet werden soll
' * @param  Date        Das Format. Als Standart ist das Systemdatumsformat
' * @param  Boolean     Auf Datum schneiden
' * @return Date
' */
Public Function castDate( _
        ByRef iVar As Variant, _
        Optional ByVal iFormat As String = vbNullString, _
        Optional ByVal iDefaultValue As Date = 0, _
        Optional ByVal iTruncToDate As Boolean = True _
) As Date
    Dim defaultValue As Date:   defaultValue = IIf(iDefaultValue = 0, Now, iDefaultValue)
On Error GoTo ERR_H
 
    'Zuerst mit den VB-Funktionen versuchen
    castDate = strToDate(Nz(iVar, defaultValue), iFormat)
    If iTruncToDate Then castDate = truncDate(castDate)
    Exit Function
 
ERR_H:
    castDate = defaultValue
    If iTruncToDate Then castDate = truncDate(castDate)
 
End Function
 
'/**
' * Copyright mpl by ERB software | http://wiki.yaslaw.info
' * Schneidet die Zeit ab
' * @param  Date        Datum [+ Zeit]
' * @retrun Date        Datum ohne Zeit
' */
Private Function truncDate(Optional ByVal iDateTime As Date) As Date
    truncDate = DateSerial(Year(iDateTime), Month(iDateTime), Day(iDateTime))
End Function
 
'/**
' * Castet Irgendwas zu einem Double
' * @param  Variant     Wert der gecastet werden soll
' * @param  Integer     Optional: Bei einem String mit mehreren Zahlen ist dies der Index, welche Zahl genommen werden soll
' * @param  Double      Optional: Wert, welcher im Fehlerfall zurückgegeben werden soll
' * @return Double
' */
Public Function castDbl( _
        ByRef iVar As Variant, _
        Optional ByVal iMatchIndex As Integer = 1, _
        Optional ByVal iDefaultValue As Double = 0 _
) As Double
    Dim tryStep As castTrySteps: tryStep = tryVBACast
On Error GoTo ERR_H
 
TRY_1__WITH_VBA_CAST:
    'Zuerst mit den VB-Funktionen versuchen
    castDbl = CDbl(Nz(iVar, iDefaultValue))
    Exit Function
 
TRY_2__WITH_REGEX:
    'Ansonsten mittels RegEx den ersten Wert ermitteln
    If Not rx_like(C_NUM_PATTERN, iVar) Then GoTo TRY_3__SET_DEFAULT
    castDbl = CDbl(rx_choose(C_NUM_PATTERN, iVar, iMatchIndex))
    Exit Function
 
TRY_3__SET_DEFAULT:
    'Es handelt sich um irgendwas komischen. Ein UDT, Ein Objekt oder sontwas.
    castDbl = iDefaultValue
    Exit Function
 
ERR_H:
    'Es ist ien Fehler aufgetretten. Ergo versuchen wir es mit der nächsten Variante
    Select Case tryStep
        Case tryVBACast: tryStep = tryStep + 1:    Resume TRY_2__WITH_REGEX
        Case tryRegEx:   tryStep = tryStep + 1:  Resume TRY_3__SET_DEFAULT
    End Select
End Function
 
'/**
' * Castet Irgendwas zu einem Integer
' * @param  Variant     Wert der gecastet werden soll
' * @param  Integer     Optional: Bei einem String mit mehreren Zahlen ist dies der Index, welche Zahl genommen werden soll
' * @return Integer
' */
Public Function castInt( _
        ByRef iVar As Variant, _
        Optional ByVal iMatchIndex As Integer = 1, _
        Optional ByVal iDefaultValue As Double = 0 _
) As Double
    Dim tryStep As castTrySteps: tryStep = tryVBACast
On Error GoTo ERR_H
 
TRY_1__WITH_VBA_CAST:
    castInt = CInt(Nz(iVar, iDefaultValue))
    Exit Function
 
TRY_2__WITH_REGEX:
    If Not rx_like(C_NUM_PATTERN, iVar) Then GoTo TRY_3__SET_DEFAULT
    castInt = CInt(rx_choose(C_NUM_PATTERN, iVar, iMatchIndex))
    Exit Function
 
TRY_3__SET_DEFAULT:
    castInt = iDefaultValue
    Exit Function
 
ERR_H:
    Select Case tryStep
        Case tryVBACast: tryStep = tryStep + 1:    Resume TRY_2__WITH_REGEX
        Case tryRegEx:   tryStep = tryStep + 1:  Resume TRY_3__SET_DEFAULT
    End Select
End Function
 
'/**
' * Castet Irgendwas zu einem Long
' * @param  Variant     Wert der gecastet werden soll
' * @param  Integer     Optional: Bei einem String mit mehreren Zahlen ist dies der Index, welche Zahl genommen werden soll
' * @return Long
' */
Public Function castLng( _
        ByRef iVar As Variant, _
        Optional ByVal iMatchIndex As Integer = 1, _
        Optional ByVal iDefaultValue As Long = 0 _
) As Long
    Dim tryStep As castTrySteps: tryStep = tryVBACast
On Error GoTo ERR_H
 
TRY_1__WITH_VBA_CAST:
    castLng = CLng(Nz(iVar, iDefaultValue))
    Exit Function
 
TRY_2__WITH_REGEX:
    If Not rx_like(C_NUM_PATTERN, iVar) Then GoTo TRY_3__SET_DEFAULT
    castLng = CLng(rx_choose(C_NUM_PATTERN, iVar, iMatchIndex))
    Exit Function
 
TRY_3__SET_DEFAULT:
    castLng = iDefaultValue
    Exit Function
 
ERR_H:
    Select Case tryStep
        Case tryVBACast: tryStep = tryStep + 1:  Resume TRY_2__WITH_REGEX
        Case tryRegEx:   tryStep = tryStep + 1:  Resume TRY_3__SET_DEFAULT
    End Select
End Function