VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Dates"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private Type WhenType                   'nitty-gritty details of a date
  Year As Integer
  Month As Integer
  Day As Integer
  Hour As Integer
  Minute As Integer
  Second As Integer
End Type
Dim TodayValue As WhenType

Public Sub AdvanceDate(InputDate As Date, IntervalType As String, Interval As Integer) 'advance entry time
     Dim A As WhenType
     Call UnPackDate(InputDate, A)
5    Select Case UCase$(IntervalType)      'update next execute date/time based on interval type
       Case "Y"
6        A.Year = A.Year + Interval        'yearly
7      Case "M"
11       A.Month = A.Month + Interval
12     Case "W"                            'weekly
17       A.Day = A.Day + Interval * 7
18     Case "D"                            'daily
23       A.Day = A.Day + Interval
24     Case "H"                            'hourly
30       A.Hour = A.Hour + Interval
31     Case "I"                            'by the minute
38       A.Minute = A.Minute + Interval
39     Case "S"                            'by the second
47       A.Second = A.Second + Interval
55   End Select
56   Call RationalDate(A)
     Call PackDate(A, InputDate)
End Sub

Function ConCat(S1 As String, Sep As String, S2 As String) As String 'returns S1+Sep+S2 if S2 <> "", otherwise returns S1; if S1 = "" returns S2
  If Trim(S2) <> "" Then
    If S1 = "" Then
      ConCat = S2
    Else
      ConCat = S1 + Sep + S2
    End If
  Else
    ConCat = S1
  End If
End Function

Public Function CreateDateTime(ADate As String, ATime As String) As Date 'creates a date/time stamp
  CreateDateTime = CDate(DateValue(ADate) + TimeValue(ATime))
End Function

Public Function Date2KToDate(dt) As Date 'Format yyyymmdd as Date
  Date2KToDate = DateSerial(Val(Left$(dt, 4)), Val(Mid$(dt, 5, 2)), Val(Right$(dt, 2)))
End Function

Public Function Date2KToStdDate(dt) As String 'Format yyyymmdd as mm/dd/yyyy
  Date2KToStdDate = DateToStdDate(Date2KToDate(dt))
End Function

Public Function DateTo2KDate(dt As Date) As String 'Format date as yyyymmdd
  DateTo2KDate = Format$(DatePart("yyyy", dt), "0000") + _
                 Format$(DatePart("m", dt), "00") + _
                 Format$(DatePart("d", dt), "00")
End Function

Public Function DateToStdDate(dt As Date) As String 'Format date as mm/dd/yyyy
  DateToStdDate = Format$(DatePart("m", dt), "00") + "/" + _
                  Format$(DatePart("d", dt), "00") + "/" + _
                  Format$(DatePart("yyyy", dt), "0000")
End Function

Public Function FormatDate2K(ADate As Date) As String 'Format Date as yyyymmdd
  Dim m As String
  Dim d As String
  Dim y As String
  m = Format$(DatePart("m", ADate), "00") 'get month
  d = Format$(DatePart("d", ADate), "00") 'get day
  y = DatePart("yyyy", ADate)           'get year
  If y < "1990" Then y = "200" + Right$(y, 1)
  FormatDate2K = y & m & d              'format result as yyyymmdd
End Function

Public Function FormatDateTime2K(A As Date) As String 'Format sortable date and time for 2000 and beyond as yyyymmddhhmmss
  Dim Stamp As Date
  Stamp = A
  FormatDateTime2K = FormatDate2K(Stamp) + FormatSortableTime(Stamp)
End Function

Public Function FormatSortableTime(A) As String 'Format Time as hhmmss
  FormatSortableTime = Format$(DatePart("h", A), "00") + _
                       Format$(DatePart("n", A), "00") + _
                       Format$(DatePart("s", A), "00")
End Function

Public Function FormInputDate(Inp As String) As String
1    Dim d As String
2    Dim P1 As Long
3    Dim P2 As Long
4    Dim Mo As String
5    Dim DY As String
6    Dim Yr As String
7    Dim CMonth As String
8    Dim CYear As String
9    Dim ErMsg As String
10   On Error GoTo HandleTheError
11   CMonth = DatePart("m", Now)           'set up current month/year
12   While Len(CMonth) < 2
13     CMonth = "0" + CMonth
14   Wend
15   CYear = DatePart("yyyy", Now)
16   d = Trim(Inp)                         'get user input
17   P1 = InStr(d, "/")                    'look for / in input string
18   If P1 <> 0 Then                       '/ used in in string
19     P2 = InStr(P1 + 1, d, "/")          'look for another /
20     If P2 - P1 = 2 Then                 'second / at 2 beyond means single digit month
21       d = InsertString(d, "0", P2 - 2)
22     End If
23     If (P2 = 0) And (Len(d) - P1 = 1) Then 'single digit day with no year
24       d = InsertString(d, "0", P1)
25       d = d + "/" + CYear
26     ElseIf P2 = 0 Then                  'year not supplied
27       d = d + "/" + CYear
28     Else                                'year supplied
29       If Len(d) - P2 = 2 Then           'check for and fix 2-digit year
30         d = InsertString(d, Left$(CYear, 2), P2)
31       End If
32     End If
33     While Len(d) < 10
34       d = "0" + d
35     Wend
36   Else                                  'no / in string; use length to understand
37     Select Case Len(d)
         Case 1
38         d = CMonth + "0" + d + CYear    'input was d
39       Case 2
40         d = CMonth + d + CYear          'input was dd
41       Case 3, 4
42         d = d + CYear                   'input was mmdd
43       Case 5, 6
44         d = InsertString(d, Left$(CYear, 2), Len(d) - 2) 'input was mmddyy
45       Case 7, 8
46         'do nothing
47       Case Else
48     End Select
49     While Len(d) < 8                    'pad to proper length
50       d = "0" + d
51     Wend
52     d = InsertString(d, "/", 2)         'insert slashes for common format
53     d = InsertString(d, "/", 5)
54   End If
55   ErMsg = ""                            'check for problems
56   Mo = Left$(d, 2)
57   If Mo < "01" Or Mo > "12" Or Not IsNumeric(Mo) Then ErMsg = ErMsg + "Invalid Month."
58   DY = Mid$(d, 4, 2)
59   If DY < "01" Or DY > "31" Or Not IsNumeric(DY) Then ErMsg = ConCat(ErMsg, " ", "Invalid Month.")
60   Yr = Right$(d, 4)
61   If Yr < "1900" Or Yr > "2200" Or Not IsNumeric(Yr) Then ErMsg = ConCat(ErMsg, " ", "Invalid Year.")
62   If Len(d) > 10 Then
63     FormInputDate = ConCat(ErMsg, " ", "Invalid date format: use mm/dd/yyyy format")
64   Else
65     Inp = d                             'return modified input
66     FormInputDate = ErMsg               'return errors, if any
67   End If
68   Exit Function
HandleTheError:
69   MsgBox "Dates.FormInputDate: Error" + str(Err.Number) + " at line" + str(Erl) + ": " + Err.Description, vbOKOnly, "I've got a Problem!"
70   Exit Function
End Function

Function InsertString(S1 As String, S2 As String, l As Long) 'Insert S2 into S1 after character L
  InsertString = Left$(S1, l) + S2 + Right$(S1, Len(S1) - l)
End Function

Private Sub PackDate(A As WhenType, OutputDate As Date)
  OutputDate = DateSerial(A.Year, A.Month, A.Day)
  OutputDate = OutputDate + TimeSerial(A.Hour, A.Minute, A.Second)
End Sub

Private Sub RationalDate(W As WhenType)
  Dim NumDays As Integer
  If W.Second > 59 Then
    W.Minute = W.Minute + 1
    W.Second = W.Second - 60
  End If
  If W.Minute > 59 Then
    W.Hour = W.Hour + 1
    W.Minute = W.Minute - 60
  End If
  If W.Hour > 23 Then
    W.Day = W.Day + 1
    W.Hour = W.Hour - 24
  End If
  If (W.Month = 9) Or (W.Month = 4) Or (W.Month = 6) Or (W.Month = 11) Then
    NumDays = 30                        '30 days hath September, April, June, and November
  ElseIf W.Month = 2 Then               'save February
    If Int(W.Year / 4) <> W.Year / 4 Then
      NumDays = 28                      'which has 28
    Else
      NumDays = 29                      'except in leap years when it has 29
    End If
  Else
    NumDays = 31                        'all the rest have 31
  End If
  While W.Day > NumDays
    W.Month = W.Month + 1
    W.Day = W.Day - NumDays
  Wend
  While W.Month > 12
    W.Year = W.Year + 1
    W.Month = W.Month - 12
  Wend
End Sub

Public Function StdDateTo2KDate(dt As String) As String 'converts mm/dd/yyy to yyyymmdd
  Dim Year As Integer
  Dim Month As Integer
  Dim Day As Integer
  Dim I As Integer
  Dim s As String
  s = dt                                'make local copy of  input date
  I = InStr(s, "/")
  Month = Val(Left$(s, I - 1))
  s = Right$(s, Len(s) - I)
  I = InStr(s, "/")
  Day = Val(Left$(s, I - 1))
  s = Right$(s, Len(s) - I)
  Year = Val(s)
  StdDateTo2KDate = DateTo2KDate(DateSerial(Year, Month, Day))
End Function

Public Function StdDateToDate(dt As String) As Date 'converts mm/dd/yyy to Date
  Dim Year As Integer
  Dim Month As Integer
  Dim Day As Integer
  Dim I As Integer
  Dim s As String
  s = dt                                'make local copy of  input date
  I = InStr(s, "/")
  Month = Val(Left$(s, I - 1))
  s = Right$(s, Len(s) - I)
  I = InStr(s, "/")
  Day = Val(Left$(s, I - 1))
  s = Right$(s, Len(s) - I)
  Year = Val(s)
  StdDateToDate = DateSerial(Year, Month, Day)
End Function

Private Sub UnPackDate(InputDate As Date, A As WhenType)
  A.Year = DatePart("yyyy", InputDate)  'start with today's values
  A.Month = DatePart("m", InputDate)
  A.Day = DatePart("d", InputDate)
  A.Hour = DatePart("h", InputDate)
  A.Minute = DatePart("n", InputDate)
  A.Second = DatePart("s", InputDate)
End Sub

Private Sub Class_Initialize()
  Dim TD As Date
  TD = Now
  TodayValue.Year = DatePart("yyyy", TD) 'start with today's values
  TodayValue.Month = DatePart("m", TD)
  TodayValue.Day = DatePart("d", TD)
  TodayValue.Hour = DatePart("h", TD)
  TodayValue.Minute = DatePart("n", TD)
  TodayValue.Second = DatePart("s", TD)
End Sub