'**************************************
' 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