'************************************** ' Name: Date conversion ' Description:To render a VB date variab ' le into different formats is easy. The o ' ther way round requires some manual work ' . This class does it for you. Simply cal ' ling "ConvertDate(myDate, myFormat)" tra ' nsforms the date in the given format int ' o a VB date. ' By: Klemens Schmid ' ' ' Inputs:Date in an arbitrary format and ' a format string describing this format, ' e.g. m-d-y, y-m-d, m/d/y, d.m.y. ' ' Returns:A VB Date ' 'Assumes:None ' 'Side Effects:None ' 'Warranty: 'Code provided by Planet Source Code(tm) ' (http://www.Planet-Source-Code.com) 'as ' is', without warranties as to performanc ' e, fitness, merchantability,and any othe ' r warranty (whether expressed or implied ' ). 'Terms of Agreement: 'By using this source code, you agree to ' the following terms... ' 1) You may use this source code in per ' sonal projects and may compile it into a ' n .exe/.dll/.ocx and distribute it in bi ' nary format freely and with no charge. ' 2) You MAY NOT redistribute this sourc ' e code (for example to a web site) witho ' ut written permission from the original ' author.Failure to do so is a violation o ' f copyright laws. ' 3) You may link to this code from anot ' her website, provided it is not wrapped ' in a frame. ' 4) The author of this code may have re ' tained certain additional copyright righ ' ts.If so, this is indicated in the autho ' r's description. '************************************** 'Outlook productivity tools from Klemens ' Schmid (klemens.schmid@gmx.de) 'For more visit www.schmidks.de/klemens 'This class provides a conversion from a ' n arbitrary date format to VB type Date. ' 'It can be used e.g. for conversion of d ' ates 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") 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 posi ' tion of day, month and year in the forma ' t 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 for ' mat 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 t ' o 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' Lex ' 4VB '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' Lex ' 4VB '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