Yaslaw.Info

User Tools

Site Tools

You are here: Yaslaw.Info » VBA » Cast » [VBA] strToDouble()
Trace:
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
vba:cast:strtodouble [16.05.2014 10:14:45]
yaslaw [Code] 		vba:cast:strtodouble [16.10.2015 12:00:22] (current)
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.//​
  
-{{:​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 12: Line 22:
  
 Im Gegensatz zu [[.:​todoublegeneric]] werden in dieser Funktion die Trennzeichen klar definiert. Im Gegensatz zu [[.:​todoublegeneric]] werden in dieser Funktion die Trennzeichen klar definiert.
- 
-===== Anforderungen ==== 
-Die strToDouble -Funktion greift auf andere Funktionen zu, die ich bereits erstellt habe. 
-=== rx-Funktionen:​ rx_choose() & rx_replace() & rx_escape_string() === 
-Für die Nummer-Cast-Funktionen verwende ich rx Funktionen aus [[..:​functions:​rx:​index#​version_mit_cache|[VBA] RegExp Functions mit Cache]] 
- 
-=== print_r() === 
-[[:​vba:​functions:​print_r:​]] wird nur für die Beispiele gebraucht. Diese Funktion wird im Einsatz nicht gebraucht 
  
 ===== Definition ===== ===== Definition =====
Line 41: 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 48: 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 97: Line 100:
  
 ===== Vergleich mit anderen Cast-Funktionen für Double ===== ===== Vergleich mit anderen Cast-Funktionen für Double =====
-{{section>​.:​compairetodoublefunctions#​Vergleichstabelle&​noheader&​firstseconly}}+{{section>​:vba:​compairetodoublefunctions#​Vergleichstabelle&​noheader&​firstseconly}}
  
 ===== 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.1400228085.txt.gz · Last modified: 16.05.2014 10:14:46 (external edit)

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