User Tools

Site Tools


vba:cast:strtodate

[VBA] strToDate()

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.

Version 2.5.0 - 15.03.2016

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

Definition

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

Parameterliste

  • iDateS Der Datumsstring, der in ein Datum geparst werden soll
  • iFormat Das Datumsformat. Wird eines der folgenden Zeichen als Trennzeichen verwendet, muss es mit einem \ maskiert werden (siehe Beispiele): M D Y H N S
  • iParams Weitere Parameter. Siehe dazu der Enumerator tdtParams. DIese sind mit + kombinierbar. Default ist tdtIgnoreCase
  • iFirstDayOfWeek Angabe zum ersten Wochentag. Schweiz → Montag
  • iFirstWeekOfYear Angabe zum ersten Woche im Jahr
  • oNanoSecounds Rückgabewert für die Nanosekunden (Siehe Beispiel | Extraktion von Nanosekunden)

Enumerators

tdtParams

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

Formatidentifikatoren

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)
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
@ Delemiter bei unklarer Trennung (siehe Beispiel unklare Formate)

Fehlerrückgabe

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

Access/Excel

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

Anwendungsbeispiele

Hier einige Anwendungsbeispiele

Für die Ausgabe der Resultate verwendete ich die Funktion [VBA] print_r().

Ohne Format

Es wird intern cDate angewendet

print_r strToDate("5.9.2013")
<Date> 05.09.2013

Mit Format

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

Länder Formatchaos

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

Unklare Formate

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

Die Funktion der Paramters

'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

FirstDayOfWeek und FirstWeekOfYear

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

Extraktion von Nanosekunden

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

Datumsstring umformatieren

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'

Code

cast_strtodate.bas
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
 
 
 
vba/cast/strtodate.txt · Last modified: 28.04.2017 09:33:17 by yaslaw