This shows you the differences between two versions of the page.
Both sides previous revision Previous revision Next revision | Previous revision | ||
vba:cast:strtodouble [29.04.2015 11:23:59] yaslaw |
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.// | //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 13: | 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 42: | 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 49: | 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 98: | 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> | + |