'-------------------------------------------------------------------------------
'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