|
Option Explicit
Const Err_UnexpectedChar = 1 + vbObjectError + 512 Const Err_UnexpectedEnd = 2 + vbObjectError + 512 Dim mintPosDay As Integer Dim mintPosMonth As Integer Dim mintPosYear As Integer Dim mstrDelim As String Dim maMonthNames As Variant Dim mintDay As Integer Dim mintMonth As Integer Dim mintYear As Integer Dim mcntDMY_value As Integer Dim mcntDMY_format As Integer Private Property Let DMY_format(s As String) ' 'called by the parser to assign the position of day, 'month and year in the format string Select Case s Case "d":mintPosDay = mcntDMY_format Case "m":mintPosMonth = mcntDMY_format Case "y":mintPosYear = mcntDMY_format End Select mcntDMY_format = mcntDMY_format + 1 End Property Private Property Let Delim(s As String) 'delimiter between day, month and year If mstrDelim <> "" Then If mstrDelim <> s Then Err.Raise Err_UnexpectedChar End If Else mstrDelim = s End If End Property Private Property Get Delim() As String Delim = mstrDelim End Property Private Sub CheckDelim(ch As String) 'check whether delimiter matches the format If ch <> mstrDelim Then Err.Raise Err_UnexpectedChar End If End Sub Private Property Let DMY_value(s As String) 'check the passed string and assign it to the 'appropriate member Select Case mcntDMY_value Case mintPosYear mintYear = s Case mintPosDay mintDay = s Case mintPosMonth If Val(s) = 0 Then 'seems to be a month name 'get the month index If IsEmpty(maMonthNames) Then 'need the month names Err.Raise 13 'ok, 'Type mismatch' doesn't fit perfectly End If Dim i% For i = 0 To 11 If LCase(maMonthNames(i)) = LCase(s) Then mintMonth = i + 1 Exit For End If Next Else 'assign month index mintMonth = Val(s) End If End Select 'proceed mcntDMY_value = mcntDMY_value + 1 End Property Public Property Let DateFormat(ByVal s As String) mcntDMY_format = 0 'init 'This code was generated by Klemens' Lex4VB 'Get it from http://www.schmidks.de Dim Token$ Dim State%, OldState% Dim Cnt% Dim ch$ Dim p% On Error Goto Trap p = 1: State = 0: OldState = -1 s = s & Chr(0) Do While p <= Len(s) If State = OldState Then Cnt = Cnt + 1 Else Cnt = 0 OldState = State ch = Mid$(s, p, 1) Select Case State Case 0: If ch Like "[dmy]" Then DMY_format = ch State = 1 Else: Err.Raise Err_UnexpectedChar End If Case 1: If ch Like "[-/.]" Then Delim = ch State = 2 Else: Err.Raise Err_UnexpectedChar End If Case 2: If ch Like "[dmy]" Then DMY_format = ch State = 3 Else: Err.Raise Err_UnexpectedChar End If Case 3: If ch Like "[-/.]" Then Delim = ch State = 4 Else: Err.Raise Err_UnexpectedChar End If Case 4: If ch Like "[dmy]" Then DMY_format = ch State = 5 Else: Err.Raise Err_UnexpectedChar End If Case 5: If Asc(ch) = 0 Then State = 5 Else: Err.Raise Err_UnexpectedChar End If End Select p = p + 1 Loop If State <> 5 Then Err.Raise Err_UnexpectedEnd Exit Property Trap: If Err.Number = Err_UnexpectedEnd Or ch = vbNullChar Then Err.Description = "Unexpected End of string" Else Err.Description = "Unexpected character " & ch & " _ at position " & p End If Err.Raise Err.Number End Property Public Property Let MonthNames(a As Variant) If UBound(a) <> 11 Then Err.Raise 9 'subscript out of range End If maMonthNames = a End Property Public Function ConvertDate(DateString As String, _ Optional DateFormat As String) mcntDMY_value = 0 If Len(DateFormat) > 0 Then Me.DateFormat = DateFormat End If ParseDate DateString ConvertDate = DateSerial(mintYear, mintMonth, mintDay) End Function Sub ParseDate(ByVal s As String) 'This code was generated by Klemens' Lex4VB 'Get it from http://www.schmidks.de Dim Token$ Dim State%, OldState% Dim Cnt% Dim ch$ Dim p% On Error Goto Trap p = 1: State = 0: OldState = -1 s = s & Chr(0) Do While p <= Len(s) If State = OldState Then Cnt = Cnt + 1 Else Cnt = 0 OldState = State ch = Mid$(s, p, 1) Select Case State Case 0: If ch Like "[0-9a-zA-Z]" Then If Cnt > 3 Then Err.Raise Err_UnexpectedChar Token = Token & ch State = 0 ElseIf ch Like "[-/.]" Then DMY_value = Token: CheckDelim ch Token = "" State = 1 Else: Err.Raise Err_UnexpectedChar End If Case 1: If ch Like "[0-9a-zA-Z]" Then If Cnt > 3 Then Err.Raise Err_UnexpectedChar Token = Token & ch State = 1 ElseIf ch Like "[-/.]" Then DMY_value = Token: CheckDelim ch Token = "" State = 2 Else: Err.Raise Err_UnexpectedChar End If Case 2: If ch Like "[0-9a-zA-Z]" Then If Cnt > 3 Then Err.Raise Err_UnexpectedChar Token = Token & ch State = 2 ElseIf Asc(ch) = 0 Then DMY_value = Token State = 2 Else: Err.Raise Err_UnexpectedChar End If End Select p = p + 1 Loop If State <> 2 Then Err.Raise Err_UnexpectedEnd Exit Sub Trap: If Err.Number = Err_UnexpectedEnd Or ch = vbNullChar Then Err.Description = "Unexpected End of string" Else Err.Description = "Unexpected character " & ch & _ " at position " & p End If Err.Raise Err.Number End Sub Inputs:Date in an arbitrary format and a format string describing this format, es. m-d-y, y-m-d, m/d/y, d.m.y. It can be used e.g. for conversion of dates found in Web pages. It can handle numeric months as well as month names. Sample for using this class: Dim oDF as New clsDateFormat oDF.MonthNames = Array("Jan", "Feb", "M ar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec") MsgBox oDF.ConvertDate("2000-Sep-01", "y-m-d") |