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/cast
'Environment  : VBA 2010 +
'Version      : 1.0.0
'Name         : cValue
'Author       : Stefan Erb (ERS)
'History      : 19.11.2014 - ERS - Creation
'-------------------------------------------------------------------------------
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
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
' * @return Varaint
' */
Public Function cValue(ByVal iString As String, 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
    
    If iHandling And cvhNullTextAsNull And UCase(iString) = "NULL" Then
        cValue = Null
        Exit Function
    End If
    If iHandling And cvhEmptyAsNull And iString = Empty Then
        cValue = Null
        Exit Function
    End If
    
    'Nummern
    If IsNumeric(iString) Then
        cValue = CByte(iString):    If cValue = iString Then Exit Function
        cValue = CInt(iString):     If cValue = iString Then Exit Function
        cValue = CLng(iString):     If cValue = iString Then Exit Function
        cValue = CDbl(iString):     If cValue = iString Then Exit Function
        cValue = CDec(iString):     Exit Function
    End If
    
    'Boolean
    Err.Clear
    cValue = CBool(iString):    If Err.Number = 0 Then Exit Function
    
    'Datum
    If IsDate(iString) Then
        cValue = CDate(iString)
        Exit Function
    End If
    
    'Datum in # Delemiter
    If rxDateString Is Nothing Then Set rxDateString = cRegExp("/^#(.*)#$/")
    If rxDateString.test(iString) Then
        cValue = CDate(rxDateString.execute(iString)(0).subMatches(0))
        Exit Function
    End If
    
    'String in Delemiter
    If rxDelemitedString Is Nothing Then Set rxDelemitedString = cRegExp("/^[#""'\[](.*)([""'#\]])$/") '0: String ohne Delemiter, 1: End-Delemiter: '," oder ]
    If rxDelemitedString.test(iString) Then
        Dim sm As Object: Set sm = rxDelemitedString.execute(iString)(0).subMatches
        cValue = Replace(sm(0), "\" & sm(1), sm(1))
        Exit Function
    End If
    'String 1 zu 1 zurückgeben
    cValue = iString
    On Error GoTo 0
End Function

'/**
' * Erstellt ein RegExp-Object mit den Grundeinstellungen
' * V2.0.0
' * @param  String          Pattern analog RegExp
' * @param  rxpFlagsEnum    Eigenschaften von Regexp. Global, IgnoreCase und Multiline.
' *                         Die Eigenschaften können mit + kombiniert werden
' * @return RegExp
' */
Private Function cRegExp(ByVal iPattern As String) As Object
    Static rxCachedPattern As Object
    If rxCachedPattern Is Nothing Then
        Set rxCachedPattern = CreateObject("VBScript.RegExp")
        rxCachedPattern.pattern = "^([@&!/~#=\|])(.*)\1([igm]{0,3})$"
    End If
    Dim parts As Object: Set parts = rxCachedPattern.execute(iPattern)(0).subMatches
    Set cRegExp = CreateObject("VBScript.RegExp")
    cRegExp.pattern = parts(1)
    cRegExp.IgnoreCase = parts(2) Like "*i*"
    cRegExp.Global = parts(2) Like "*g*"
    cRegExp.Multiline = parts(2) Like "*m*"
End Function