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.4.0
'Author       : Stefan Erb (ERS)
'History      : 15.01.2014 - ERS - Creation
'               ...
'               03.11.2014 - ERS - Für Frankreich das Leerzeichen als Tausender zulassen
'                                  NZ für Ecel mit bedinget Kompilierung hinzugfügt
'               03.12.2014 - ERS - cRegExp() durch cRx() ersetzt
'               14.11.2016 - ERS - Doe Potenzen hinzugefügt:  toDblGeneric("2.3 e-2") -> 0.023
'-------------------------------------------------------------------------------
Option Explicit

'Für Excel muss NZ() noch definert werden
'Darum hier angeben mit was dass die FUnktion läuft: "EXCEL"/"ACCESS"
'#Const prog = "EXCEL"
#Const prog = "ACCESS"

'   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, Punkt und Leerzeichen
'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
    
    'Nummer aus Text extrahieren
    If strRx.test(NZ(numberV)) Then numberV = strRx.execute(numberV).item(0).subMatches(0)

    'Den String umdrehen.
    Dim numS        As String:      numS = StrReverse(IIf(NZ(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, potenz As String, absNum As String, decimalSep As String, thousendSep As String, decimalSep2 As String, sign2 As String * 1
    'Patternauswertung:
    '0: Vorzeichen danach
    '1: E-Wert
    '2: Ganze Zahl, ohne Vorzeichen
    '3: Dezimaltrennzeichen (Im Fall, dass Tausendertrennzeichen vorhanden sind)
    '4: Tausendertrennzeichen
    '5: Dezimaltrennzeichen (Im Fall, dass keine Tausendertrennzeichen vorhanden sind)
    '6: dummy (Damit im (?:..) kein  Reihenfolgechaos ensteht
    '7: Vorzeichen davor
    list toDblGRx.execute(numS).item(0), sign, potenz, absNum, decimalSep, thousendSep, decimalSep2, , sign2
    'Dezimaltrennzeichen ermitteln. Entweder in part 2 oder 4
    decimalSep = Trim(decimalSep & decimalSep2)
    'Vorzeichen ermitteln. Davor oder 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, ".")) & StrReverse(potenz))

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
'-------------------------------------------------------------------------------
' Patterns:
' {$T}: C_TODBLG_THOUSEND_PATTERNS  alle möglichen Hockommas, Komma, Punkt und Leerzeichen
' {$D}: C_TODBLG_DECIMAL_PATTERNS   Komma und Punkt
' {$S}: C_TODBLG_SIGN_PATTERNS      Plus und Minus
'/**
' * RegEx um die erste Nummer aus einem String zu lösen
' * @return RegExp
' */
Private Property Get strRx() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx(cPattern("/([{$S}]?[\s]*[{$T}{$D}\d]+\s*(?:E[+-]?\d+)?[\s]*[{$S}]?)/i"))
    Set strRx = rx
End Property

'/**
' * RegEx um das Delemiterhändling im Spezialfall 1.234 zu handhaben
' * @return RegExp
' */
Private Property Get toDblGRx() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx(cPattern("/^([{$S}]?)\s*(\d+[+-]?E)?\s*(\d+(?:([{$D}])\d{3}([{$T}])\d+|([{$D}])\d{1,3}()|)[\d{$T}]*)\s*([{$S}]?)$/i"))
    Set toDblGRx = rx
End Property

'/**
' * RegEx um den Sonderfall zu ermitteln
' * @return RegExp
' */
Private Property Get dhRx() As Object
    Static rx As Object:    If rx Is Nothing Then Set rx = cRx(cPattern("/^\d{3}[{$D}]\d{1,3}$/"))
    Set dhRx = rx
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, "{$D}", C_TODBLG_DECIMAL_PATTERNS)
    cPattern = replace(cPattern, "{$T}", C_TODBLG_THOUSEND_PATTERNS)
    cPattern = replace(cPattern, "{$S}", C_TODBLG_SIGN_PATTERNS)
End Function

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

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

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