Attribute VB_Name = "cast_strToDouble"
'-------------------------------------------------------------------------------
'File         : cast_strToDouble.bas
'               Copyright mpl by ERB software
'               http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/strtodate
'Environment  : VBA 2007 +
'Version      : 2.0
'Author       : Stefan Erb (ERS)
'History      : 07.01.2014 - ERS - Creation
'               14.01.2014 - ERS - Soweit umprogrammiert, dass möglichst viel gechached wird,
'                                  falls die Funktion in einem Query verwendet wird
'               14.09.2015 - ERS - Alle fremden Methoden entfernt
'-------------------------------------------------------------------------------
Option Explicit

Public Enum stdStrToDoubleFLags
    stdNoSign = 2 ^ 0           'Die Zahl hat kein Vorzeichen oder schneider es ab (analog zu abs())
    stdSignLeft = 2 ^ 1         'Das Vorzeichen ist auf der linken Seite, falls vorhanen
    stdSignRight = 2 ^ 2        'Das Vorzeichen ist auf der rechten Seite, falls vorhanen
    stdNoCache = 2 ^ 3          'Funktion wird nicht mit gecachten Formaten verarbeitet
End Enum

'/**
' * API Funktionen um die Systemtrennzeichen zu ermitteln
' */
Private Declare Function getLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long
Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long
Private Const LOCALE_SDECIMAL = &HE
Private Const LOCALE_STHOUSAND = &HF

'/**
' * Privtae Konstanten
'*/
Private Const C_SIGN_PATTERN = "[-\+]?"               'RegEx Pattern für die Vorzeichen
'/**
' * Die Angaben des letzten Laufes werden gespeichert. So muss bei mehrmaligem Aufruf mit
' * denselben Parametern nicht mehr alles neu ermittelt werden
' */
Private pThousandSeparator      As String               'Cached Aktuelles Tausendertrennzeichen
Private pDecimalSeparator       As String               'Cached Aktuelles Dezimaltrennzeichen
Private pFlags                  As stdStrToDoubleFLags  'Cached Aktuelles Vorzeichenposition
Private pReset                  As Boolean

'/**
' * Konvertiert einen String in ein Double unter Anagabe der Trennzeichen und Vorzeichenposition
' * @param  String
' * @param  Variant         Tausendertrennzeichen. Wenn Null, dann das Trennezichen aus den Usersettungs des System
' * @param  Variant         Dezimaltrennzeichen. Wenn Null, dann das Trennezichen aus den Usersettungs des System
' * @param  stdStrToDoubleFLags Flags: Angabe über die Lage des VOrzeichens und ob keine Dezimalzeichen vorhanden sind. Ist Kombinierbar
' * @return Double
' * Errors:
' * 13          Der String lässt sich nicht in ein Double wandeln
' */
Public Function strToDouble( _
        ByVal iNumberS As String, _
        Optional ByVal iThousandSeparator As String = Empty, _
        Optional ByVal iDecimalSeperator As String = Empty, _
        Optional ByVal iFlags As stdStrToDoubleFLags = stdSignRight + stdSignLeft _
) As Double
    Dim numberS             As String   'Nummerstring während der verarbeitung

    'Wenn sich das Dezimalzeichen oder die FLags ändern, Patterns neu herleiten
    pReset = CStr(iDecimalSeperator) <> pDecimalSeparator _
            Or CStr(iThousandSeparator) <> pThousandSeparator _
            Or iFlags <> pFlags _
            Or (iFlags And stdNoCache) = stdNoCache
            
    If pReset Then
        thousandSeparator = iThousandSeparator
        decimalSeparator = iDecimalSeperator
        pFlags = iFlags
    End If

    'Die erste Patternübereinstimmung extrahieren und alle tausenderzeichen entfernen
    numberS = Replace(rxFormat.execute(iNumberS)(0).value, thousandSeparator, vbNullString)
    'Die parsen
    numberS = rxFormat.Replace(numberS, replacement)
    
    'Nur wenn Vorzeichen an beiden Edden möglich sind, das erste gefundene nehmen
    If signLeft And signRight Then numberS = rxToMatchSign.Replace(numberS, "$1")

    strToDouble = CDbl(numberS)
End Function

'/**
' * RegExp um die Zahl zu parsen
' * subMatches: 0) Vorzeichen Links 1) Ganze Zahl (inkl. Tausendertrennzeichen) 2) Nachkommastellen 3) Vorzeichen nach der Zahl
' * @return RegExp
' */
Private Property Get rxFormat() As Object
    Static pRxFormat As Object
    If pRxFormat Is Nothing Or pReset Then Set pRxFormat = cRx("/(" & IIf(signLeft, "[-\+]?", "") & ")([\d" & thousandSeparatorPattern & "]*)?(?:" & decimalSeparatorPattern & "(\d*))?(" & IIf(signRight, "[-\+]?", "") & ")/")
    Set rxFormat = pRxFormat
End Property

'/**
' * Erstellt den Ersetzungsstring für rxFormat
' * @return String
' */
Private Property Get replacement() As String
    Static pRepl As String
    If pReset Then
        If signLeft Then pRepl = "$1"
        If signRight Then pRepl = pRepl & "$4"
        pRepl = pRepl & "$2"
        pRepl = pRepl & userDecimalSeparator & "$3"
    End If
    replacement = pRepl
End Property

'/**
' * RegExp um doppelte Vorzeichen zu eliminieren
' * @return RegExp
' */
Private Property Get rxToMatchSign() As Object
    Static pRx As Object: If pRx Is Nothing Then Set pRx = cRx("/([-+])[-+]/")
    Set rxToMatchSign = pRx
End Property


'/**
' * Flag für Vorzeichen Links
' * @return Boolean
' */
Private Property Get signLeft() As Boolean
    Static pSign As Boolean: If pReset Then pSign = (pFlags And stdSignLeft) = stdSignLeft
    signLeft = pSign
End Property

'/**
' * Flag für Vorzeichen Rechts
' * @return Boolean
' */
Private Property Get signRight() As Boolean
    Static pSign As Boolean: If pReset Then pSign = (pFlags And stdSignRight) = stdSignRight
    signRight = pSign
End Property



'/**
' * Handelt die Tausendertrennzeichen
' * @return String
' */
Private Property Let thousandSeparator(ByVal iThousandSeparator As String)
    pThousandSeparator = iThousandSeparator
End Property
Private Property Get thousandSeparator() As String
    If pReset Then pThousandSeparator = IIf(pThousandSeparator = Empty, userThousandSeparator, pThousandSeparator)
    thousandSeparator = pThousandSeparator
End Property

'/**
' * Pattern für den Tausenderseperator
' * @return String
' */
Private Property Get thousandSeparatorPattern() As String
    Static pattern As String: If pReset Then pattern = rxEscapeString(thousandSeparator)
    thousandSeparatorPattern = pattern
End Property
'/**
' * Ermittelt das Userformat für das Tausendertrennzeichens aus den Settings
' * @return String
'*/
Private Property Get userThousandSeparator() As String
    Static separator As String
    If separator = Empty Or pReset Then
        Dim data As String * 10
        Dim ret As Long: ret = getLocaleInfo(GetUserDefaultLCID, LOCALE_STHOUSAND, data, 10)
        separator = Left$(data, ret - 1)
    End If
    userThousandSeparator = separator
End Property

'/**
' * handelt die Dezimaltrennzeichen
' * @return String
' */
Private Property Let decimalSeparator(ByVal iDecimalSeparator As String)
    pDecimalSeparator = iDecimalSeparator
End Property
Private Property Get decimalSeparator() As String
    If pReset Then pDecimalSeparator = IIf(pDecimalSeparator = Empty, userDecimalSeparator, pDecimalSeparator)
    decimalSeparator = pDecimalSeparator
End Property

'/**
' * Pattern für den Dezimalseperator
' * @return String
' */
Private Property Get decimalSeparatorPattern() As String
    Static pattern As String: If pReset Then pattern = rxEscapeString(decimalSeparator)
    decimalSeparatorPattern = pattern
End Property

'/**
' * Ermittelt das Userformat für das Dezimaltrennzeichen aus den Settings
' * @return Trennzeichen
'*/
Private Property Get userDecimalSeparator() As String
    Static separator As String
    If separator = Empty Or pReset Then
        Dim data As String * 10
        Dim ret As Long: ret = getLocaleInfo(GetUserDefaultLCID, LOCALE_SDECIMAL, data, 10)
        separator = Left$(data, ret - 1)
    End If
    userDecimalSeparator = separator
End Property



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

'/**
' * Escapte alle Sonderzeichen um eine rxFormat-Pattern zu erstellen
' *
' *     string = rxEscapeString(string)
' *
' * @example    rxEscapeString("Hallo Welt. Geht es dir (noch) gut?")
' *             Hallo Welt\. Geht es dir \(noch\) gut\?
' * @param  String
' * @return String
' */
Private Function rxEscapeString(ByVal iString As String) As String
    Static rx As Object: If rx Is Nothing Then Set rx = cRx("/([\\\*\+\?\|\{\[\(\)\^\$\.\#])/")
    rxEscapeString = rx.Replace(iString, "\$1")
End Function