Attribute VB_Name = "cast_toDblGeneric"
'-------------------------------------------------------------------------------
'File         : cast_toDblGeneric.bas
'               Copyright mpl by ERB software
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/toDoubleGeneric
'Environment  : VBA 2007 +
'Version      : 1.3.2
'Author       : Stefan Erb (ERS)
'History      : 15.01.2014 - ERS - Creation
'               11.02.2014 - ERS - Neu wird auch eine Nummer aus einem Text gefiltert.
'               14.02.2014 - ERS - Den Parameter iDelemiterHandling hinzugefügt
'               09.10.2014 - ERS - Cache in private Properties extrahiert, clearCache-Parameter entfernt
'               31.10.2014 - ERS - Cache-Variablen von Modul-Private zu Static gewechselt
'               03.11.2014 - ERS - Für Frankreich das Leerzeichen als Tausender zulassen
'                                  NZ für Ecel mit bedinget Kompilierung hinzugfügt
'-------------------------------------------------------------------------------
Option Explicit

'Für Excel muss NZ() noch definert werden
#Const prog = "EXCEL"

'   double = toDblGeneric(input [,delemiterHandling])

'/**
' * steuert das verhalten, wenn nicht klar ist, ob das letzte Zeichen ein Dezimaltrennzeichen oder ein Tausendertrennzeichen ist
' */
Public Enum tngDelemiterHandling
    tngDecimal = 0                  'Der Text 1,234 wird als 1.234 zurückgegeben
    tngThousend = 1                 'Der Text 1,234 wird als 1234 zurückgegeben
End Enum


'/**
' * User-Konstanten. Diese können für weitere Fälle ergänzt werden
' */
'Alle möglichen Tausendertrennzeichen als Regulärer Ausdruck
Private Const C_TODBLG_THOUSEND_PATTERNS = "`´',\. "   'alle möglichen Hockommas, Komma und Punkt
'Alle möglichen Dezimaltrennzeichen als Regulärer Ausdruck
Private Const C_TODBLG_DECIMAL_PATTERNS = ",\."     'Komma und Punkt
'Alle möglichen Vorzeichen als Regulärer AUsdruck
Private Const C_TODBLG_SIGN_PATTERNS = "-\+"        'Plus und Minus

'/**
' * Fixe Konstanten. Diese sollten nicht verandert werden
' */
Private Const C_TODBLG_DECIMAL_PLACEHOLDER = "#DEC#"    'Temporäres Decimaltrennzeichen, dass gesetzt wird. Muss einfach eindeutig sein und darf keines der Tausender- und Dezimatrennzeichen sein

'/**
' * Wandelt einen String in ein Double um, ohne genaue defnitionen
' * Mögliche Tausendertrennzeichen: ` ´ ' , . keines
' * Mögliche Dezimaltrennzeichen: , . keines
' * Mögliche Vorzeichen vor oder nach der Zahl, mit oder ohne Leerzeichen dazwischen: + - keines
' * @param  Variant     Input
' * @param  tngDelemiterHandling
' *                     Es gibt den Sonderfall '3.456'. Ist das jetzt 3456 oder 3,456. Mit tngDecima wird daraus 3.456, mit tngThosend 3456
' * @return Double
'*/
Public Function toDblGeneric( _
        Optional ByVal iNumberV As Variant = Null, _
        Optional ByVal iDelemiterHandling As tngDelemiterHandling = tngDecimal _
) As Double
    Dim numberV As Variant: numberV = iNumberV
    Dim parts       As Object
On Error GoTo Err_Handler

    If strRx.test(NZ(numberV)) Then
        numberV = strRx.execute(numberV).item(0).subMatches(0)
    End If

    'Den String umdrehen. IIIf() anstelle von Nz(), damit es auch in Excel funktioniert
    Dim numS        As String:      numS = StrReverse(IIf(IsNull(numberV) Or numberV = Empty, 0, numberV))
    'Prüfen, ob der string überhaubt greift
    If Not toDblGRx.test(numS) Then Err.Raise (13)  'Type Missmatch

    'Die einzelnen Teile auslesen
    Dim sign As String * 1, absNum As String, decimalSep As String, thousendSep As String, decimalSep2 As String, sign2 As String * 1
    'Patternauswertung:
    '0: Vorzeichen danach
    '1: Ganze Zahl, ohne Vorzeichen
    '2: Dezimaltrennzeichen (Im Fall, dass Tausendertrennzeichen vorhanden sind)
    '3: Tausendertrennzeichen
    '4: Dezimaltrennzeichen (Im Fall, dass keine Tausendertrennzeichen vorhanden sind)
    '5: dummy (Damit im (?:..) kein  Reihenfolgechaos ensteht
    '6: Vorzeichen davor
    list toDblGRx.execute(numS).item(0), sign, absNum, decimalSep, thousendSep, decimalSep2, , sign2
    'Dezimaltrennzeichen ermitteln. Entweder in part 2 oder 4
    decimalSep = Trim(decimalSep & decimalSep2)
    'Vorzeichen ermitteln. Davor der danach.
    sign = Trim(sign2 & sign)

    'Prüfen, ob es sich um eine Zahl ohne Nachkommastellen handelt
    '- Kein Tausendertrennzeiche, Dezimaltrennzeichen vorhanden, Delimiterhändling = Tausender, hat nach dem Trennzeichen 3 Stellen, hat vor dem Trennzeichen höchstens 3 Stellen
    '- Das Dezimaltrennzeichen ist mit dem Tausnedertrennzeichen identisch, hat nach dem Trennzeichen 3 Stellen, hat vor dem Trennzeichen höchstens 3 Stellen
    If _
            ( _
                (thousendSep = Empty And decimalSep <> Empty And iDelemiterHandling = tngThousend) _
                Or (decimalSep = thousendSep) _
            ) _
            And dhRx.test(absNum) _
    Then
        'Trennzeichen entfernen
        numS = replace(absNum, IIf(thousendSep = Empty, decimalSep, thousendSep), vbNullString)
    Else
        'Dezmaltrennzeichen markieren
        numS = replace(absNum, decimalSep, C_TODBLG_DECIMAL_PLACEHOLDER, , 1)
        'Tausendertrennzeichen entfernen
        numS = replace(numS, thousendSep, vbNullString)
    End If

    'Markierung des Dezimaltrennzeichens durch einen . ersetzen und das Vorzeichen mitgeben
    toDblGeneric = CDbl(sign & StrReverse(replace(numS, C_TODBLG_DECIMAL_PLACEHOLDER, ".")))

Exit_Handler:
    Set parts = Nothing
    Exit Function
Err_Handler:
    Set parts = Nothing
    'Err 13: Type missmatch
    Call Err.Raise(13, "toDblGeneric", "Type missmatch" & vbCrLf & vbCrLf & "'" & iNumberV & "' is not a valid Number", Err.helpFile, Err.helpContext)
    Resume
End Function

'-------------------------------------------------------------------------------
'--- PRIVATE PROPERTIES
'-------------------------------------------------------------------------------
'/**
' * RegEx um die erste Nummer aus einem String zu lösen
' * @return RegExp
' */
Private Property Get strRx() As Object
    Static pStrRx As Object
    Const C_PATTERN = "/([{$sign}]?[\s]*[{$thousend}{$decimal}\d]+[\s]*[{$sign}]?)/"
    If pStrRx Is Nothing Then Set pStrRx = cRegExp(cPattern(C_PATTERN))
    Set strRx = pStrRx
End Property

'/**
' * RegEx um das Delemiterhändling im Spezialfall 1.234 zu handhaben
' * @return RegExp
' */
Private Property Get toDblGRx() As Object
    Static pToDblGRx As Object
    Const C_PATTERN = "/^([{$sign}]?)\s*(\d+(?:([{$decimal}])\d{3}([{$thousend}])\d+|([{$decimal}])\d{1,3}()|)[\d{$thousend}]*)\s*([{$sign}]?)$/"
    If pToDblGRx Is Nothing Then Set pToDblGRx = cRegExp(cPattern(C_PATTERN))
    Set toDblGRx = pToDblGRx
End Property

'/**
' * RegEx um den Sonderfall zu ermitteln
' * @return RegExp
' */
Private Property Get dhRx() As Object
    Static pDhRx As Object
    Const C_PATTERN = "/^\d{3}[{$decimal}]\d{1,3}$/"
    If pDhRx Is Nothing Then Set pDhRx = cRegExp(cPattern(C_PATTERN))
    Set dhRx = pDhRx
End Property

'-------------------------------------------------------------------------------
'--- PRIVATE FUNCTIONS
'-------------------------------------------------------------------------------
'/**
' * Stellt ein Patterns anhand der Settings zusammen
' * @param  String
' * @return String
' */
Private Function cPattern(ByVal iPattern As String) As String
    cPattern = replace(iPattern, "{$decimal}", C_TODBLG_DECIMAL_PATTERNS)
    cPattern = replace(cPattern, "{$thousend}", C_TODBLG_THOUSEND_PATTERNS)
    cPattern = replace(cPattern, "{$sign}", C_TODBLG_SIGN_PATTERNS)
End Function

'-------------------------------------------------------------------------------
'--- LIBRARIES
'-------------------------------------------------------------------------------

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

'/**
' * Dito zu List. Aber die Argumente ist ein vordimensionierter Array
' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/list
' * V1.0.1 (gekürzte Version)
' * @param  Liste           Array, Dictionary, Collection, Regexp.MatchCollection, Regexp.Match oder DAO.Recordset
' * @param  Array<Varaint>  Auflistung der Variablen, die abgefüllt werden
' * @return Boolean         Angabe, ob die ganze Sache gültig war
' */

Private Function list( _
        ByRef iList As Variant, _
        ParamArray oParams() As Variant _
) As Boolean
    Dim uBnd    As Long:    uBnd = UBound(oParams)
    list = iList.subMatches.count > 0:     If Not list Then Exit Function
    If uBnd > iList.subMatches.count - 1 Then uBnd = iList.subMatches.count - 1
    Dim i As Integer: For i = 0 To uBnd
        If Not IsMissing(oParams(i)) Then oParams(i) = iList.subMatches(i)
    Next i
End Function



#If prog = "EXCEL" Then
    Private Function NZ(ByRef iValue As Variant, Optional ByRef iDefault As Variant = Empty) As Variant
        If IsNull(iValue) Then
            NZ = iDefault
        Else
            NZ = iValue
        End If
    End Function
#End If