Diese Funktion parst ein String in ein Date. Im Gegensatz zu cDate() von VBA kann hier das Datumsformat mitgegeben werden. Die meisten Formatzeichen von VBA werden unterstüzt.
Download cast_strtodate.bas (V-2.5.0)
Um die Funktion bei mehrmaliger Anwendung zu beschleunigen, werden die RegExp-Objekte mit den generierten Pattern in ein privates Dictionary-Objekt gespeichert. Das führt zu einer erheblichen Geschwindigkeitsverbesserung bei der Anwendung innerhalb eines SQL-Statements
siehe auch [VBA] DateTime
date = strToDate(string [,format [,parameters [,erster Tag der Woche [,erste Woche des Jahres [,nanosekunden]]]]])
Public Function strToDate( _ ByVal iDate As Variant, _ Optional ByVal iFormat As String = vbNullString, _ Optional ByVal iParams As tdtParams = tdtIgnoreCase, _ Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _ Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem, _ Optional ByRef oNanoSecounds As Long _ ) As Variant
Public Enum tdtParams tdtNone = 0 tdtIgnoreCase = 2 ^ 0 'Gross-Kleinschreibung bei Trennzeichen ignorieren tdtExtractDate = 2 ^ 1 'Der String beimnhaltet vor oder nach dem Datum noch andere Werte. Das Datum wird extrahiert tdtIgnoreError = 2 ^ 2 'Fehler werden ignoriert. Im Fehlerfall wird NULL zurückgegeben tdtFomat2 = 2 ^ 3 'Es handelt sich um ein Format im Stil von {$DD}.{$MM} End Enum
Format | Beschreibung |
---|---|
m | Monat ohne führende Null (1-12) |
mm | Monat mit führende Null (01-12) |
d | Tag ohne führende Null (1-31) |
dd | Tag mit führende Null (01-31) |
yy | zweistelliges oder vierstelliges Jahr |
yyyy | vierstelliges Jahr |
q | QuartalAnfang (1.1.x - 1.10.x) |
QuartalEnde (31.3.x - 31.12.x) | |
h | Stunden ohne führende Null(0-24) |
hh | Stunden mit führende Null(00-24) |
n | Minuten ohne führende Null(0-59) |
nn | Minuten mit führende Null(00-59) |
s | Sekunden ohne führende Null(0-59) |
ss | Sekunden mit führende Null(00-59) |
am/pm | Erwartet eine Angabe von AM oder PM |
a/p | Erwartet eine Angabe von A oder P |
y | Tag des Jahres |
w | Tag der Woche |
ww | Woche im Jahr |
f | Nanosekunden |
@ | Delemiter bei unklarer Trennung (siehe Beispiel unklare Formate) |
Fehlernummer | Beschreibung |
---|---|
13 | Es wurde kein Format mitgegeben und der String lässt sich nicht durch das Sytem in ein Datum wandeln. Siehe cdate() |
-2147221503 (C_SD_ERR_INVALID_FORMAT) | Das Format ist nicht parsbar |
-2147221502 (C_SD_ERR_NOT_PARSEBLE) | Der String passt nicht mit dem Format überein |
Excel kennt leider die lebenswichtige Funktion NZ() nicht. Darum muss für Excel diese Funktion hinzuprogrammiert sein. Das steurt man über die Kompilierungskonstante isAccess
Am Anfang vom Code befindet sich darum die Zeile
Für Access ist dies True, für Excel False
#Const isAccess = True
Hier einige Anwendungsbeispiele
Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().
Es wird intern cDate angewendet
print_r strToDate("5.9.2013")
<Date> 05.09.2013
Diverse Formatierungen mit Formaten
'Mit dem Format den Tag und Monat genau zuordnern. Damit aus 5.9 der 9te Mai wird print_r strToDate("5.9.2013", "m.d.yyyy") <Date> 09.05.2013 'Einen String ohne Trennzeichen print_r strToDate("05092013", "mmddyyyy") <Date> 09.05.2013 'und mit Uhrzeit print_r strToDate("05092013_151765", "mmddyyyy_hhnnss") <Date> 09.05.2013 15:18:05 'und mit AM/PM print_r strToDate("05092013_121765_AM", "mmddyyyy_hhnnss_am/pm") <Date> 09.05.2013 00:18:05 'nur die Zeit print_r strToDate("17:6:65", "h:n:s") <Date> 17:07:05 'Quartalsanfang print_r strToDate("Q3 2015", "\QQ YYYY") <Date> 01.07.2015 'Und das Quartalsende print_r strToDate("Q3 2015", "\QQQ YYYY") <Date> 30.09.2015
Ein Datum kann je nach Land unterschiedlich geschrieben werden. Dass kann zu Fehler führen. Nehmen wir das Amerikanische Format MM/DD/YYYY. In der Schweiz und in Deutschland haben wir DD.MM.YYYY. VBA nimmt die Ländereinstellung vom PC-Profil. Wenn der Tag kleiner oder gleich 12 ist, dann haben wir ein Problem. Dann erkennt VBA den Tag als Monat und das Resultat ist Falsch.
Als Beispiel der 5. Januar 2017. Im Amerikanischen Format 01/05/2017. cDate mit Schweizer Einstellung macht daraus den 1. Mai 2017.
'Einfacher cDate. Der Tag ist Kleinergleich als 12. Das Resultat ist falsch print_r cDate("01/05/2017") <Date> 01.05.2017 'Wenn die zweite Position über 12 ist, erkennt VBA, dass es sich um den Tag handeln muss print_r cDate("01/15/2017") <Date> 15.01.2017 'Mit strToDate und einem definierten Format wird das Datum richtig umgesetzt print_r strToDate("01/05/2017", "MM/DD/YYYY") <Date> 05.01.2017
Mit Trennzeichen, die auch Formate sind. Darum müsse diese Zeichen im Format mit einem \ maskiert werden Das Format ist: D gefolgt vom Tag (1-31), M gefolgt von einem Monat (01-12) und Y gefolgt vom Jahr
print_r strToDate("D1M05Y2013", "\DD\MMM\YYYYY") <Date> 01.05.2013
Ein Bespiel, bei dem nicht klar ist wo die Trennung ist. In Dem Fall der 133te Tag im Jahr 2015.
print_r strToDate("1332015", "YYYYY") <Date> 15.01.1332 'Und jetzt mit einem @ als Delemiter um genau anzugeben wo der neue Pattern beginnt print_r strToDate("1332015", "Y@YYYY") <Date> 13.05.2015
'Ohne tdtExtractDate print_r strToDate("Heute ist der 1.12.2014", "d.m.yyyy") -> Fehler -2147221502 'Mit tdtExtractDate print_r strToDate("Heute ist der 1.12.2014", "d.m.yyyy", tdtExtractDate) <Date> 01.12.2014 'Mit tdtExtractDate, ohne tdtIgnoreCase. Man beachte, der 'Monat' ist im Format klein geschrieben (und maskiert) print_r strToDate("Heute ist der 1te des 12ten Monats 2014", "dte \de\s mte\n \mo\nat\s yyyy", tdtExtractDate) -> Fehler -2147221502 'Und kombiniert mit tdtIgnoreCase print_r strToDate("Heute ist der 1te des 12ten Monats 2014", "dte \de\s mte\n \mo\nat\s yyyy", tdtExtractDate + tdtIgnoreCase) <Date> 01.12.2014
Bei Formaten mit Wochentage und Wochennummer ist es entscheidend, was als Erste Woche des Jahres gerechnet wird und mit welchem Tag die Woche beginnt.
'Zweiter Wochentag in der 3ten Woche im Jahr 2015 nach Systemeinstellungen Schweiz print_r strToDate("2/3/2015", "W/WW/YYYY") <Date> 13.01.2015 'Dasselbe wenn die Erste Woche als die erste Volle Woche gerechnet wird print_r strToDate("2/3/2015", "W/WW/YYYY",,,vbFirstFullWeek) <Date> 20.01.2015 'Und dann noch di Ienstellung, dass der erste tag in der Woche der Sonntag ist (ja, das gibt es in gewissen Ländern) print_r strToDate("2/3/2015", "W/WW/YYYY",,vbSunday,vbFirstFullWeek) <Date> 19.01.2015
Leider können die Nanosekunden nicht im Datumsformat ausgegeben werde. Das ist so von VBA nicht vorgesehen. Über den Rückgabeparameter oNanoSecounds kann trotzdem darauf zugegriffen werden
Dim nano As Long Dim dt As Date dt = strToDate("12:13:34.01234", "HH:MM:NN.F", , , , nano) print_r dt -> <Date> 31.12.2000 12:34:00 print_r nano -> <Long> 12340000
Noch ein kleines Beispiel zum umformatieren eines Datum-Strings in ein anderer.
Das brauche ich häufig wenn ich mit Schnittstellen zu anderen System arbeite.
In dem Beispiel habe ich ein Datum im Format ddmmyyyy
. Für das andere System brauche ich das Format m/d/yyyy
,
wobei hier /
nicht für den Loakalen Seperator steht, sondern für den String /
. Darum muss er für den
VBA-Befehl format() mit \ maskiert werden.
print_r format(strToDate("01061972", "ddmmyyyy"), "m\/d\/yyyy") <String> '6/1/1972'
Attribute VB_Name = "cast_strToDate" '------------------------------------------------------------------------------- 'File : cast_strToDate.bas ' Copyright mpl by ERB software ' All rights reserved ' http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/strtodate 'Environment : VBA 2007 + 'Version : 2.5.0 'Name : strToDate 'Author : Stefan Erb (ERS) 'History : 13.11.2013 - ERS - Creation ' : 22.01.2014 - ERS - Platzhalterzeichen als Trennzeichen erlaubt ' ... ' 07.09.2015 - ERS - Null und Zahlen als Input zugelassen ' 29.09.2015 - ERS - Berechnungsfehler bei w und ww mit vbFirstFullWeek behoben ' 17.11.2015 - ERS - q und qq hinzugefügt ' 15.03.2016 - ERS - Format2 hinzugefügt. Also Formate in {$..} '------------------------------------------------------------------------------- 'In Excel funktionieren Events nicht. Auch der NZ() gibt es dort nicht. 'Darum hier angeben ob es sich um MS Access handelt oder eben nicht. Leider gibts datzu keine Systemvariable #Const isAccess = True Option Explicit '------------------------------------------------------------------------------- ' -- ! SETTINGS ! '------------------------------------------------------------------------------- ' date = strToDate(string [,format [,parameters [,erster Tag der Woche [,erste Woche des Jahres [,nanosekunden]]]]]) '------------------------------------------------------------------------------- '--- PUBLIC MEMBERS '------------------------------------------------------------------------------- '/** ' * Zusätzliche Parameters zu strToDate ' */ Public Enum tdtParams tdtNone = 0 tdtIgnoreCase = 2 ^ 0 'Gross-Kleinschreibung bei Trennzeichen ignorieren tdtExtractDate = 2 ^ 1 'Der String beimnhaltet vor oder nach dem Datum noch andere Werte. Das Datum wird extrahiert tdtIgnoreError = 2 ^ 2 'Fehler werden ignoriert. Im Fehlerfall wird NULL zurückgegeben tdtFomat2 = 2 ^ 3 'Es handelt sich um ein Format im Stil von {$DD}.{$MM} End Enum '/** ' * Public Konstanten ' */ Public Const C_PATTERN_DELEMITER = "@" 'Fakultatives Patterntrennzeichen '/** ' * Error Konstantens ' */ Public Const C_SD_ERR_INVALID_FORMAT = -2147221504 + 1 'Das Format ist nicht parsbar Public Const C_SD_ERR_NOT_PARSEBLE = -2147221504 + 2 'Der String passt nicht mit dem Format überein '------------------------------------------------------------------------------- '--- PUBLIC METHODES '------------------------------------------------------------------------------- '/** ' * Parst ein String in ein Datum anhand eines mitgegeben Formates ' * @param String Der Datumsstring ' * @param String Das Format. Als Standart ist das Systemdatumsformat ' * @param tdtParams Weitere Parameter ' * @param VbDayOfWeek Angabe zum ersten Wochentag. Schweiz -> Montag. Standard: Systemeinstellung ' * @param VbFirstWeekOfYear Angabe zum ersten Woche im Jahr. Schweiz -> vbFirstFourDays. Standard: Systemeinstellung ' * @param Long Rückgabewert für die Nanosekunden ' * @return Date ' * ' * Die folgenden Zeichen müssen im Format mit einem \ maskiert werden, wenn sie als Trennzeichen eingesetzt werden sollen: ' * M D Y H N S W @ Bie AMPM: A\M/P\M, \A/P ' * Bsp.: strToDate("D01M11Y2014", "\DDD\MMM\YYYYY") -> 1 November 2014 ' * Bsp.: strToDate("D01M11Y2014", "D{$DD}M{$MM}Y{$YYYY}") -> 1 November 2014 ' * ' * Bisher umgesetzte Formate: ' * m Monat ohne führende Null (1-12) ' * mm Monat mit führende Null (01-12) ' * d Tag ohne führende Null (1-31) ' * dd Tag mit führende Null (01-31) ' * yy Zweistelliges Jahr ' * yyyy Vierstelliges Jahr ' * q QuartalAnfang (1.1.x - 1.10.x) ' * qq QuartalEnde (31.3.x - 31.12.x) ' * h Stunden ohne führende Null(0-24) ' * hh Stunden mit führende Null(00-24) ' * n Minuten ohne führende Null(0-59) ' * nn Minuten mit führende Null(00-59) ' * s Sekunden ohne führende Null(0-59) ' * ss Sekunden mit führende Null(00-59) ' * am/pm Erwartet eine Angabe von AM oder PM ' * a/p Erwartet eine Angabe von A oder P ' * y Tag des Jahres ' * w Tag der Woche ' * ww Woche im Jahr ' * f Nanosekunden ' * ' * Allgemein. Sollte anhand des Formates eine Reihenfolge nicht klar sein, dann kann vor jedes Pattern ein @ gesetzt werden ' * Format "YYYYY". Jahreszahl & Tag im Jahr. Es ist unklar ob das Jahr oder der Tag als erste kommt. -> "Y2YYYY" ' * ' * Errors: ' * 13 Es wurde kein Format mitgegeben und der String lässt sich nicht durch das Sytem in ein Datum wandeln. Siehe cdate() ' * -2147221503 (C_SD_ERR_INVALID_FORMAT) Das Format ist nicht parsbar ' * -2147221502 (C_SD_ERR_NOT_PARSEBLE) Der String passt nicht mit dem Format überein ' */ Public Function strToDate( _ ByVal iDate As Variant, _ Optional ByVal iFormat As String = vbNullString, _ Optional ByVal iParams As tdtParams = tdtIgnoreCase, _ Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _ Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem, _ Optional ByRef oNanoSecounds As Long _ ) As Variant On Error GoTo Err_Handler Dim dates As String: dates = IIf((iParams And tdtIgnoreCase), UCase(CStr(NZ(iDate))), CStr(NZ(iDate))) 'Wenn kein Format mitgegen wird, wird versucht mittels cDate() das Datum herauszukriegen If iFormat = vbNullString Then strToDate = CDate(dates) Exit Function End If Dim d As Integer, m As Integer, y As Integer: d = 0: m = 0: y = 0 Dim h As Integer, n As Integer, s As Integer: h = 0: n = 0: s = 0 Dim dow As Integer, doy As Long, woy As Integer: dow = 0: doy = 0: woy = 0 Dim ampm As String 'überprüfen, welcher Art von Format es ist If Not (iParams And tdtFomat2) = tdtFomat2 And rxParseFormat2.test(iFormat) Then iParams = iParams + tdtFomat2 'Format parsen Dim frmtKey As String: frmtKey = parseFormatToCache(iFormat, iParams) 'Überprüfen ob der Datumsstring auf das Format passt If formats(frmtKey).item("RegExp").test(dates) = False Then Err.Raise C_SD_ERR_NOT_PARSEBLE, "strToDate", "Datum passt nicht auf das Format" & vbCrLf & vbCrLf & formats(frmtKey).item("RegExp").pattern Dim match As Object: Set match = formats(frmtKey).item("RegExp").execute(dates)(0) Dim i As Integer: For i = 0 To match.subMatches.count - 1 Dim sm As String: sm = match.subMatches(i) Select Case formats(frmtKey).item("codePos")(i) Case "DAY": d = sm Case "MONTH": m = sm Case "YEAR": y = sm Case "HOUR": h = sm Case "MINUTE": n = sm Case "SECOUND": s = sm Case "AM/PM": ampm = UCase(Left(sm, 1)) Case "DAY_OF_YEAR": doy = sm Case "DAY_OF_WEEK": dow = sm Case "WEEK_OF_YEAR": woy = sm Case "NONOSECOUND": oNanoSecounds = 10 ^ 9 * CDbl("0." & sm) Case "QUARTER": d = 1: m = (sm - 1) * 3 + 1 Case "QUARTER_END": d = 0: m = sm * 3 + 1 End Select Next i 'Spezialfälle, welche pestehende Grössen überschreiben If doy <> 0 Then 'Tag des Jahres m = 1 'Monat auf Januar setzen d = doy 'Tag des Jehres als Tag übernehmen ElseIf woy <> 0 Then 'Woche des Jahres m = 1 'Monat auf Januar setzen d = getDaysOfFirstDayOfWeek(y, woy, iFirstDayOfWeek, iFirstWeekOfYear) + IIf(dow = 0, 0, (dow - 1)) End If 'AM/PM Stundenkorrektur If ampm = "P" And h <> 0 And h < 12 Then h = h + 12 ElseIf ampm = "A" And h = 12 Then h = 0 End If strToDate = IIf(y + m + d <> 0, DateSerial(y, m, d), 0) + IIf(h + n + s <> 0, TimeSerial(h, n, s), 0) Set match = Nothing Exit_Handler: Set match = Nothing Exit Function Err_Handler: If Not (iParams And tdtIgnoreError) = tdtIgnoreError Then Err.Raise Err.number, Err.source, Err.DESCRIPTION, Err.HelpFile, Err.HelpContext strToDate = Null Resume Exit_Handler Resume End Function '------------------------------------------------------------------------------- '--- PRIVATE METHODES '------------------------------------------------------------------------------- '/** ' * Ermittelt den Jahrestag des Ersten Tages einer Woche ' * @param Long Jahr ' * @param Integer Woche im Jahr ' * @param VbDayOfWeek Angabe zum ersten Wochentag. Schweiz -> Montag ' * @param VbFirstWeekOfYear Angabe zum ersten Woche im Jahr ' * @return Long ' */ Private Function getDaysOfFirstDayOfWeek( _ ByVal iYear As Long, _ ByVal iWeek As Integer, _ Optional ByVal iFirstDayOfWeek As VbDayOfWeek = vbUseSystemDayOfWeek, _ Optional ByVal iFirstWeekOfYear As VbFirstWeekOfYear = vbUseSystem _ ) As Long Dim firstJan As Date: firstJan = DateSerial(iYear, 1, 1) Dim firstJanW As Integer: firstJanW = DatePart("W", firstJan, iFirstDayOfWeek, vbFirstFullWeek) Dim diff As Integer: diff = IIf(DatePart("WW", firstJan, iFirstDayOfWeek, iFirstWeekOfYear) = 1, firstJanW, firstJanW - 7) getDaysOfFirstDayOfWeek = ((iWeek - 1) * 7) + 2 - diff End Function '/** ' * Zerlegt das Format in seine Einzelteile und erstellt ein RegEx-Pattern umd den Datumsstring zu zerlegen ' * @param String Das Format. Als Standart ist das Systemdatumsformat ' * @param tdtParams Weitere Parameter ' * @return String Key des gecachten RegExp ' */ Private Function parseFormatToCache(ByVal iFormat As String, ByVal iParams As tdtParams) As String parseFormatToCache = iFormat & "_P" & iParams 'Das Format nur zerlegen, wenn es noch nicht exisiteiert If Not formats.exists(parseFormatToCache) Then Dim codePosR() As String Dim frmt As String: frmt = IIf((iParams And tdtIgnoreCase), UCase(iFormat), iFormat) Dim pattern As String: Dim rxPF As Object If Not (iParams And tdtFomat2) = tdtFomat2 Then pattern = masked2uniode(frmt) pattern = rxEscapeString(pattern) Set rxPF = rxParseFormat Else pattern = frmt Set rxPF = rxParseFormat2 End If If rxPF.test(pattern) = False Then Err.Raise C_SD_ERR_INVALID_FORMAT, "strToDate", "Ungültiges Datumsformat" Dim mc As Object: Set mc = rxPF.execute(pattern) Dim idxPos As Integer: idxPos = -1 Dim i As Integer: For i = mc.count - 1 To 0 Step -1 Dim item As String: item = mc(i).subMatches(2) If Not item = Empty Then 'Ist kein Maskiertes Zeichen idxPos = idxPos + 1: ReDim Preserve codePosR(idxPos) pattern = substrReplace(pattern, convertFormatPattern(item, codePosR(idxPos)), mc(i).firstIndex, mc(i).length) End If Next i 'Patterntrennzeichen entfernen pattern = Replace(pattern, C_PATTERN_DELEMITER, "") 'Reihenfolge der codePosR umdrehen Dim codePos() As String: ReDim codePos(idxPos) For i = 0 To idxPos codePos(i) = codePosR(idxPos - i) Next i pattern = unicodeDecode(pattern) If Not (iParams And tdtExtractDate) = tdtExtractDate Then pattern = "^" & pattern & "$" pattern = "/" & pattern & "/" & IIf((iParams And tdtIgnoreCase) = tdtIgnoreCase, "i", "") formats.add parseFormatToCache, CreateObject("scripting.Dictionary") 'RegExp zu diesem Pattrn erstellen formats(parseFormatToCache).add "codePos", codePos 'Index der SubMatches formats(parseFormatToCache).add "RegExp", cRx(pattern) End If End Function '/** ' * Maskiert einen String, damit er keine Pattern darstellt ' * @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("/([\*\+\?\|\{\[\(\)\^\.\$])/gi") '\ wird nicht maskiert rxEscapeString = rx.Replace(iString, "\$1") End Function '/** ' * Konvertiert ein gefundenen Formatteil in ein RX-Pattern. Gibt Zugleich den Datumsteil zurück ' * @param String ' * @param String ' * return String ' */ Private Function convertFormatPattern(ByVal iString As String, ByRef oCode As String) As String Select Case UCase(iString) Case "D": convertFormatPattern = "(\d{1,2})": oCode = "DAY" Case "DD": convertFormatPattern = "(\d{2})": oCode = "DAY" Case "M": convertFormatPattern = "(\d{1,2})": oCode = "MONTH" Case "MM": convertFormatPattern = "(\d{2})": oCode = "MONTH" Case "YY": convertFormatPattern = "(\d{2}|\d{4})": oCode = "YEAR" Case "YYYY": convertFormatPattern = "(\d{4})": oCode = "YEAR" Case "H": convertFormatPattern = "(\d{1,2})": oCode = "HOUR" Case "HH": convertFormatPattern = "(\d{2})": oCode = "HOUR" Case "N": convertFormatPattern = "(\d{1,2})": oCode = "MINUTE" Case "NN": convertFormatPattern = "(\d{2})": oCode = "MINUTE" Case "S": convertFormatPattern = "(\d{1,2})": oCode = "SECOUND" Case "SS": convertFormatPattern = "(\d{2})": oCode = "SECOUND" Case "AM/PM": convertFormatPattern = "(AM|PM)": oCode = "AM/PM" Case "A/P": convertFormatPattern = "([AP])": oCode = "AM/PM" Case "Y": convertFormatPattern = "(\d{1,3})": oCode = "DAY_OF_YEAR" Case "W": convertFormatPattern = "([1234567])": oCode = "DAY_OF_WEEK" Case "WW": convertFormatPattern = "(\d{1,2})": oCode = "WEEK_OF_YEAR" Case "F": convertFormatPattern = "(\.?\d{1,9})": oCode = "NONOSECOUND" Case "QQ": convertFormatPattern = "([1-4])": oCode = "QUARTER_END" Case "Q": convertFormatPattern = "([1-4])": oCode = "QUARTER" End Select End Function '------------------------------------------------------------------------------- '--- PRIVATE PROPERTIES '------------------------------------------------------------------------------- '/** ' * Managt die gecachten Formate ' * @return Dictionary ' */ Private Property Get formats() As Object Static cachedDict As Object If cachedDict Is Nothing Then Set cachedDict = CreateObject("scripting.Dictionary") Set formats = cachedDict End Property '/** ' * RegExp der die Einzelformatpatterns bestimmt ' * @return RegExp ' */ Private Property Get rxParseFormat() As Object Static cachedRx As Object If cachedRx Is Nothing Then Set cachedRx = cRx("/((?=" & C_PATTERN_DELEMITER & "?)(\\u[0-9A-F]{4})|(Y{4}|([MDHNSWYQ])\4|[MDHNSWYFQ]|A\/P|AM/PM))/ig") Set rxParseFormat = cachedRx End Property '/** ' * RegExp der die Einzelformatpatterns bestimmt ' * @return RegExp ' */ Private Property Get rxParseFormat2() As Object 'cRx("/\{\$(.*?)\}/g") Static rx As Object: If rx Is Nothing Then Set rx = cRx("/\{\$((\\u[0-9A-F]{4})|(Y{4}|([MDHNSWYQ])\4|[MDHNSWYFQ]|A\/P|AM/PM))}/ig") Set rxParseFormat2 = rx End Property '------------------------------------------------------------------------------- '--- LIBRARIES '------------------------------------------------------------------------------- '/** ' * Dies ist die Minimalversion von cRx (V2.1.0): http://wiki.yaslaw.info/dokuwiki/doku.php/vba/cast/cRx ' */ Private Function cRx(ByVal iPattern As String) As Object Static rxP As Object If rxP Is Nothing Then: Set rxP = CreateObject("VBScript.RegExp"): rxP.pattern = "^([@&!/~#=\|])?(.*)\1(?:([Ii])|([Gg])|([Mm]))*$" Dim sm As Object: Set cRx = CreateObject("VBScript.RegExp"): 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 '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Wandelt ein Unicode in ein Charakter ' * @example: unicode2char("\u20AC") -> '\€' ' * @param String Unicode ' * @return String Char ' */ Private Function unicode2Char(ByVal iUnicode As String) As String unicode2Char = ChrW(Replace(iUnicode, "\u", "&h")) End Function '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Wandelt ein Charakter in ein Unicode ' * @example: char2unicode("€") -> '\u20AC' ' * @param String(1) Charakter, der gewandelt werden soll ' * @return String Unicode ' */ Private Function char2unicode(ByVal iChar As String) As String char2unicode = Hex(AscW(iChar)) 'Hex-Wert ermitteln char2unicode = "\u" & String(4 - Len(char2unicode), "0") & char2unicode End Function '/** ' * Wandelt jedes mit \ maskierte Feld in Unicode um, ausser es handelt sich bereits um einen Unicode ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/masked2unicode ' * @param String ' * @return String ' */ Private Function masked2uniode(ByVal iString As String) As String Static rx As Object: If rx Is Nothing Then Set rx = cRx("/\\(?!u[0-9A-F]{4})(.)/") masked2uniode = iString Do While rx.test(masked2uniode) masked2uniode = rx.Replace(masked2uniode, char2unicode(rx.execute(masked2uniode)(0).subMatches(0))) Loop End Function '/** ' * Wandelt alle Unicodes in einem String in das eigentliche Zeichen zurück ' * http://wiki.yaslaw.info/dokuwiki/doku.php/vba/functions/unicodedecode ' * @param String ' * @return String ' */ Private Function unicodeDecode(ByVal iString) As String unicodeDecode = iString Static rx As Object If rx Is Nothing Then Set rx = cRx("/\\u[0-9A-F]{4}/g") If Not rx.test(unicodeDecode) Then Exit Function Dim mc As Object: Set mc = rx.execute(unicodeDecode) Dim i As Integer: For i = mc.count - 1 To 0 Step -1 unicodeDecode = substrReplace(unicodeDecode, unicode2Char(mc(i)), mc(i).firstIndex, mc(i).length) Next i End Function '/** ' * Ersetzt Text innerhalb einer Zeichenkette ' * @param String Die Eingabezeichenkette ' * @param String Die Ersetzungszeichenkette ' * @param Integer Start ' * @param Integer Länge ' * @return String ' */ Private Function substrReplace(ByVal iString As String, ByVal iReplacement As String, ByVal iStart As Integer, Optional ByVal iLength As Variant = Null) As String Dim startP As Integer: startP = IIf(Sgn(iStart) >= 0, iStart, greatest(Len(iString) + iStart, 1)) Dim length As Integer: length = NZ(iLength, Len(iString) - iStart) Dim endP As Integer Select Case Sgn(length) Case 1: endP = least(startP + length, Len(iString)) Case 0: endP = startP Case -1: endP = greatest(Len(iString) + length, startP) End Select substrReplace = Left(iString, startP) & iReplacement & Mid(iString, endP + 1) End Function '/** ' * Copyright mpl by ERB software | http://wiki.yaslaw.info ' * ' * Gibt den Grössten aus einer unbestimmten Menge von Werten zurück ' * @param Keine Objekte ' * @return Grösster Wert ' * @example greatest("Hallo Welt", 42, "Mister-X") -> Mister-X '*/ Private Function greatest(ParamArray iItems() As Variant) As Variant greatest = iItems(UBound(iItems)) Dim item As Variant: For Each item In iItems If NZ(item) > NZ(greatest) Then greatest = item Next item End Function '/** ' * Gibt den Kleinsten aus einer unbestimmten Menge von Werten zurück ' * @param Keine Objekte ' * @return Grösster Wert ' * @example least("Hallo Welt", 42, "Mister-X") -> 42 '*/ Private Function least(ParamArray iItems() As Variant) As Variant least = iItems(LBound(iItems)) Dim item As Variant: For Each item In iItems If NZ(item) < NZ(least) Then least = item Next item End Function #If Not isAccess Then '/** ' * Wandelt NULL in Empty oder einen Defaultwert ' * @param Variant ' * @param Variant ' * @return Variant ' */ 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