Yaslaw.Info

User Tools

Site Tools

You are here: Yaslaw.Info » VBA » Cast » [VBA] strToDouble()
Trace: • [VBA] techName()
vba:cast:strtodouble

Differences

This shows you the differences between two versions of the page.

Link to this comparison view

Both sides previous revision Previous revision
Next revision 		Previous revision
Last revision Both sides next revision
vba:cast:strtodouble [14.09.2015 13:02:28]
yaslaw 		vba:cast:strtodouble [14.09.2015 13:06:56]
yaslaw
Line 1: Line 1:
 +<​const>​
 +    version=2.0.0
 +    vdate=15.09.2015
 +    fname=cast_strtodouble.bas
 +    ns=%NAMESPACE%
 +    fpath=/​vba/​cast
 +</​const>​
 +
 ====== [VBA] strToDouble() ====== ====== [VBA] strToDouble() ======
 //Funktion um einen String in ein Double zu wandeln unter angabe von Tasuender- und Dezimaltrennzeichen.//​ //Funktion um einen String in ein Double zu wandeln unter angabe von Tasuender- und Dezimaltrennzeichen.//​
  
-{{:​vba:​cast:​cast_strtodouble.bas|}}+==Version %%version%% - %%vdate%%== 
 +{{%%fname%%|Download %%fname%% (V-%%version%%)}}
  
 Manchmal bekommt man Zahlen als Text in den wirrsten Formaten. Manchmal bekommt man Zahlen als Text in den wirrsten Formaten.
Line 34: Line 43:
     stdSignLeft = 2 ^ 1         '​Das Vorzeichen ist auf der linken Seite, falls vorhanen     stdSignLeft = 2 ^ 1         '​Das Vorzeichen ist auf der linken Seite, falls vorhanen
     stdSignRight = 2 ^ 2        'Das Vorzeichen ist auf der rechten Seite, falls vorhanen     stdSignRight = 2 ^ 2        'Das Vorzeichen ist auf der rechten Seite, falls vorhanen
-    ​stdWithoutDecimal ​= 2 ^ 3   ​'Explizite Angabe, dass keine Dezimalzeichen vorhanden sind+    ​stdNoCache ​= 2 ^ 3          'Funktion wird nicht mit gecachten Formaten verarbeitet
 End Enum</​code>​ End Enum</​code>​
  
Line 41: Line 50:
  
 ===== Anwendungsbeispiele ===== ===== Anwendungsbeispiele =====
-Hier einige Anwendungsbeispiele 
 > Für die Ausgabe der Resultate verwendete ich die Funktion [[:​vba:​functions:​print_r:​]]. > Für die Ausgabe der Resultate verwendete ich die Funktion [[:​vba:​functions:​print_r:​]].
 +
 +Hier einige Anwendungsbeispiele
  
 <code vb>'​Mit User-Stnadarteinstellung des Systems <code vb>'​Mit User-Stnadarteinstellung des Systems
Line 93: Line 103:
  
 ===== Code ===== ===== Code =====
-<code vb cast_strToDouble.bas>​'------------------------------------------------------------------------------- +<source ​'%%fpath%%/%%fname%%' ​vb>
-'​File ​        : strToDouble +
-' ​              ​Copyright mpl by ERB software +
-' ​              http://​wiki.yaslaw.info/​dokuwiki/​doku.php/​vba/​functions/​strtodate +
-'Environment ​ : VBA 2007 + +
-'​Version ​     : 1.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 +
-'​Requiered: ​    ​rx_escape_string() ​     http://​wiki.yaslaw.info/​dokuwiki/​doku.php/​vba/​functions/​rx/​rx_escape_string +
-' ​              ​rx_choose() ​            ​http://​wiki.yaslaw.info/​dokuwiki/​doku.php/​vba/​functions/​rx/​rx_choose +
-' ​              ​rx_replace() ​           http://​wiki.yaslaw.info/​dokuwiki/​doku.php/​vba/​functions/​rx/​rx_replace +
-' ​              Oder gleich das ganze rx_* Paket: ​  ​http://​wiki.yaslaw.info/​dokuwiki/​doku.php/​vba/​functions/​rx/​index +
-'​------------------------------------------------------------------------------- +
-Option Explicit +
- +
-Public Enum stdStrToDoubleFLags +
-    [_FIRST] = 0 +
-    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 +
-    stdWithoutDecimal = 2 ^ 3   '​Explizite Angabe, dass keine Dezimalzeichen vorhanden sind +
-    [_LAST] = 3 +
-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 userThousandSeparator ​  As String ​              '​Cached Tausendertrennzeichen aus den Usersettings +
-Private thousandSeparator ​      As String ​              '​Cached Aktuelles Tausendertrennzeichen +
-Private userDecimalSeparator ​   As String ​              '​Cached Dezimaltrennzeichen au den Usersettings +
-Private decimalSeparator ​       As String ​              '​Cached Aktuelles Dezimaltrennzeichen +
-Private decimalSeparatorPat ​    As String ​              '​Cached Regex-Pattern für Dezimaltrennzeichen +
-Private flags                   As stdStrToDoubleFLags ​ '​Cached Aktuelles Vorzeichenposition +
-Private parsePattern ​           As String ​              '​Cached Vollständiges Pattern inkl. Vorzeichen +
-Private replacement ​            As String ​              '​Cached Regex-Replacment +
- +
-'/** +
-' * 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 Variant = Null, _ +
-        Optional ByVal iDecimalSeperator As Variant = Null, _ +
-        Optional ByVal iFlags As stdStrToDoubleFLags = stdSignRight + stdSignLeft _ +
-) As Double +
-    Dim numberS ​            As String ​  '​Nummerstring während der verarbeitung +
-    Dim parts() ​            As String ​  '​AUteiling Vorkomma, Nachkomma bei gleichen Separatoren +
-     +
-    '​Tausendertrennzeichen aus Eingabe oder aus dem System auslesen +
-    If IsNull(iThousandSeparator) Then +
-        If userThousandSeparator = vbNullString Then userThousandSeparator = getUserThousandSeparator +
-        iThousandSeparator = userThousandSeparator +
-    End If +
-    If CStr(iThousandSeparator) <> thousandSeparator Then thousandSeparator = iThousandSeparator +
-     +
-    '​Dezimaltrennzeichen aus Eingabe oder aus dem System auslesen +
-    If IsNull(iDecimalSeperator) Then +
-        If userDecimalSeparator = vbNullString Then userDecimalSeparator = getUserDecimalSeparator +
-        iDecimalSeperator = userDecimalSeparator +
-    End If +
-     +
-    'Wenn sich das Deziimalzeichen oder die FLags ändern, Patterns neu herleiten +
-    If _ +
-            CStr(iDecimalSeperator) <> decimalSeparator _ +
-            Or CInt(Nz(iFlags)) <> flags _ +
-    Then +
-        '​Eingaben übernhemen +
-        decimalSeparator = iDecimalSeperator +
-        flags = iFlags +
-        '​Wandelt das Trennzeichen zu einem RegEx-Pattern ​ '​.'​ -> '​\.'​ +
-        decimalSeparatorPat = rx_escape_string(decimalSeparator) +
-        'RegEx Pattern für die Zahl zusammenstellen. +
-        parsePattern = "​(\d+)"​ & decimalSeparatorPat & "?​(\d*)"​ +
-        'Links oder Rechts den Pattern für das Vorzeichen anhängen +
-        If flags And stdNoSign Then +
-            'Kein Vorzeichen vorhanden +
-            replacement = "​$1.$2"​ +
-        ElseIf (flags And (stdSignLeft + stdSignRight)) = (stdSignLeft + stdSignRight) Then +
-            '​Vorzeichen kann Links oder Rechts vorkommen +
-            parsePattern = C_SIGN_PATTERN & "​\s*"​ & parsePattern & C_SIGN_PATTERN +
-            replacement = "​$1$4$2.$3"​ +
-        ElseIf flags And stdSignLeft Then +
-            '​Vorzeichen kann nur Links vorkommen +
-            parsePattern = C_SIGN_PATTERN & "​\s*"​ & parsePattern +
-            replacement = "​$1$2.$3"​ +
-        ElseIf flags And stdSignRight Then +
-            '​Vorzeichen kann nur Rechts vorkommen +
-            parsePattern = parsePattern & "​\s*"​ & C_SIGN_PATTERN +
-            replacement = "​$3$1.$2"​ +
-        Else +
-            '​Vorzeichen nicht geregelt - ergo keine +
-            replacement = "​$1.$2"​ +
-        End If +
-    End If +
-     +
-    If iFlags And stdWithoutDecimal Then +
-        'Keine Dezimaltrennung +
-        numberS = Replace(Replace(iNumberS,​ decimalSeparator,​ vbNullString),​ thousandSeparator,​ vbNullString) +
-    ElseIf decimalSeparator <> thousandSeparator Then +
-        '​Dezimal- und Tausendertrennzeichen sind verschieden +
-        '​Tausenderzeichen eliminieren:​ +
-        numberS = Replace(iNumberS,​ thousandSeparator,​ vbNullString) +
-    Else +
-        'Das Tausendertrennzeichen und das Dezimaltrennzeichen sind identisch. (ggf tausender nicht gesetzt) +
-        'Darum das letzte Zeichen als Dezimalzeichen werten +
-        '​String umdrehen und nach dem ersten (also vorher letzten) Trennzeichen aufsplitten +
-        parts = Split(StrReverse(iNumberS),​ decimalSeparator,​ 2) +
-        '​Erster Teil (Nachkommastellen) & Trennzeichen & Vorkommastellen mit entferneten Trennzeichen wieder zurückfrehen +
-        numberS = StrReverse(parts(0) & decimalSeparator & Replace(parts(1),​ thousandSeparator,​ vbNullString)) +
-    End If +
-         +
-    'Die erste Patternübereinstimmung extrahieren +
-    numberS = rx_choose(parsePattern,​ numberS) +
-    'Und parsen +
-    numberS = rx_replace(parsePattern,​ replacement,​ numberS) +
-     +
-    'Nur wenn Vorzeichen an beiden Edden möglich sind, das erste gefundene nehmen +
-    If flags And (stdSignLeft + stdSignRight) Then numberS = rx_replace("​([-+])[-+]",​ "​$1",​ numberS) +
-     +
-    strToDouble = CDbl(numberS) +
-End Function +
- +
-'/** +
-' * Leert den strToDouble-Cache +
-' * Wird nur bei der Entwicklung gebraucht +
-' */ +
-Public Sub resetCacheStrToDouble() +
-    userThousandSeparator = Empty +
-    thousandSeparator = Empty +
-    userDecimalSeparator = Empty +
-    decimalSeparator = Empty +
-    decimalSeparatorPat = Empty +
-    flags = Empty +
-    parsePattern = Empty +
-    replacement = Empty +
-End Sub +
- +
-'/** +
-' * Ermittelt das Userformat für das Dezimaltrennzeichen aus den Settings +
-' * @param ​ String ​ Wert, falls die Funktion fehlschlägt +
-' * @return Trennzeichen +
-'*/ +
-Private Function getUserDecimalSeparator(Optional ByVal iDefault As String = "​."​) As String +
-    Dim Data As String * 10 +
-    Dim ret As Long +
-    ret = GetLocaleInfo(GetUserDefaultLCID,​ LOCALE_SDECIMAL,​ Data, 10) +
-    getUserDecimalSeparator = IIf(ret > 0, Left$(Data, ret - 1), iDefault) +
-End Function +
- +
-'/** +
-' * Ermittelt das Userformat für das Tausendertrennzeichen aus den Settings +
-' * @param ​ String ​ Wert, falls die Funktion fehlschlägt +
-' * @return Trennzeichen +
-'*/ +
-Private Function getUserThousandSeparator(Optional ByVal iDefault As String = "'"​) As String +
-    Dim Data As String * 10 +
-    Dim ret As Long +
-    ret = GetLocaleInfo(GetUserDefaultLCID,​ LOCALE_STHOUSAND,​ Data, 10) +
-    getUserThousandSeparator = IIf(ret > 0, Left$(Data, ret - 1), iDefault) +
-End Function +
-</code> +
vba/cast/strtodouble.txt · Last modified: 16.10.2015 12:00:22 by yaslaw

Page Tools

Except where otherwise noted, content on this wiki is licensed under the following license: GNU Free Documentation License 1.3
GNU Free Documentation License 1.3 Donate Powered by PHP Valid HTML5 Valid CSS Driven by DokuWiki