Replacement for VBs IsDate

Category:

Dates and Math

Type:

Classes

Difficulty:

Intermediate

Author: Anonymous

Version Compatibility: Visual Basic 6

More information:

IsDate() is useless because it returns True if the parameter can be converted to a date using ANY regional setting. Depending on where you live either 1/30/2003 is a date OR 30/01/2003 is a date, but not both. IsDate returns true for both of these.

This function validates dates in a variety of formats commonly used in the USA.

Instructions: Copy the declarations and code below and paste directly into your VB project.

Declarations:
Public Enum enmDateFormat ' Underscores represent a seperator character e1or2M_1or2D_YY = 1 ' represents M/D/YY or M/DD/YY or MM/D/YY or MM/DD/YY e1or2M_1or2D_2or4Y ' above plus 2 or 4 digit year eMM_DD_YY eMM_DD_YYYY eYYYY_MM_DD End Enum

Code:

'   Returns True if first parameter is a valid date according
' to specified format.
' parameters:
'    p_sSource is string to be validated
'    p_lMode is expected format for p_sSource
'    [ p_IsValidateSeperator ] Allows one to compare 
'       date seperator characters against a hard coded list
'       of valid seperators, e.g., "/" or "." or "-"
'    [ p_AllowInternalSpaces ] allows one to specifiy
'       if p_sSource can contain internal spaces, e.g.,
'       "10/ 5/2003"

Public Function IsValidDateString(ByVal p_sSource As String _
                , ByVal p_lMode As enmDateFormat _
                , Optional ByVal p_IsValidateSeperator = False _
                , Optional ByVal p_AllowInternalSpaces = False) _
                As Boolean

' Determine if param is a valid date accoring to my rules, not VBs
        Dim bReturn As Boolean
        
        ' dot flunks the IsDate test, so ...
        Dim sTemp As String: sTemp = Replace(p_sSource, ".", "/")
        If IsDate(sTemp) Then
                    
            ' Validate string length
            If Not LengthCheck(p_lMode, p_sSource, p_AllowInternalSpaces) Then
                Exit Function
            Else
                p_sSource = Trim(p_sSource)
            End If
            
            ' Validate Year
            Dim lYear As Long  ' passed byref
            If Not YearCheck(p_lMode, p_sSource, lYear) Then Exit Function
            
            
            ' Validate month
            Dim lMonth As Long
            lMonth = MonthExtract(p_lMode, p_sSource)
            If lMonth = 0 Then Exit Function
            
            
            ' Validate day
            Dim lDay As Long
            lDay = DayCheck(p_lMode, p_sSource, lMonth, lYear)
            If lDay = 0 Then Exit Function
        
        
            ' [Validate seperator]    Done inline so can Exit Function
            If p_IsValidateSeperator Then
                Dim vDelims_ As Variant
                vDelims_ = Array("/", "-", ".")   ' Hardcoded for specific uses.
                
                Select Case p_lMode
                Case enmDateFormat.eMM_DD_YY, enmDateFormat.eMM_DD_YYYY
                    If Not InList(Mid(p_sSource, 3, 1), vDelims_) Then Exit Function
                    If Not InList(Mid(p_sSource, 6, 1), vDelims_) Then Exit Function
                Case enmDateFormat.eYYYY_MM_DD
                    If Not InList(Mid(p_sSource, 5, 1), vDelims_) Then Exit Function
                    If Not InList(Mid(p_sSource, 8, 1), vDelims_) Then Exit Function
                Case enmDateFormat.e1or2M_1or2D_YY
                    If Len(p_sSource) = 8 Then   ' MM\DD\YY
                        If Not InList(Mid(p_sSource, 3, 1), vDelims_) Then Exit Function
                        If Not InList(Mid(p_sSource, 6, 1), vDelims_) Then Exit Function
                    ElseIf Len(p_sSource) = 6 Then    ' M\D\YY
                        If Not InList(Mid(p_sSource, 2, 1), vDelims_) Then Exit Function
                        If Not InList(Mid(p_sSource, 4, 1), vDelims_) Then Exit Function
                    Else
                        If IsDigitsOnly(Left(p_sSource, 2)) Then   ' MM\D\YY
                            If Not InList(Mid(p_sSource, 3, 1), vDelims_) Then Exit Function
                        Else  ' M\DD\YY
                            If Not InList(Mid(p_sSource, 2, 1), vDelims_) Then Exit Function
                        End If
                        If Not InList(Mid(p_sSource, 5, 1), vDelims_) Then Exit Function
                    End If
                End Select
            End If
            
            ' just to be safe ...
            If Not IsDate(CStr(lDay) & "/" & CStr(lMonth) & "/" & CStr(lYear)) Then
                Exit Function
            Else
                bReturn = True
            End If
        
        End If
        
        IsValidDateString = bReturn

End Function

Private Function LengthCheck(ByVal p_lMode As enmDateFormat _
                    , ByVal p_sSource As String _
                    , ByVal p_AllowInternalSpaces As Boolean) _
                    As Boolean
                    
        Dim bReturn As Boolean
        
        If Not p_AllowInternalSpaces Then
            p_sSource = Replace(p_sSource, " ", "")
        End If
        
        Select Case p_lMode
        Case enmDateFormat.eMM_DD_YY
            If Len(Trim(p_sSource)) = 8 Then
                bReturn = True
            End If
        Case enmDateFormat.eMM_DD_YYYY, enmDateFormat.eYYYY_MM_DD
            If Len(Trim(p_sSource)) = 10 Then
                bReturn = True
            End If
        Case enmDateFormat.e1or2M_1or2D_YY
            If Len(Trim(p_sSource)) >= 6 And Len(Trim(p_sSource)) <= 8 Then
                bReturn = True
            End If
        Case enmDateFormat.e1or2M_1or2D_2or4Y
            If Len(Trim(p_sSource)) >= 6 And Len(Trim(p_sSource)) <= 10 Then
                bReturn = True
            End If

End Select
        
        LengthCheck = bReturn
        
End Function

Private Function YearCheck(ByVal p_lMode As enmDateFormat _
                    , ByVal p_sSource As String _
                    , ByRef p_lYear As Long) _
                    As Boolean
        
        ' Return true if a number greater than zero
        ' Year is passed back by reference
        ' IsNumeric
                    
        Dim bReturn As Boolean
        
        Dim sYear As String
        Select Case p_lMode
        Case enmDateFormat.eMM_DD_YY, enmDateFormat.e1or2M_1or2D_YY
            sYear = Right(p_sSource, 2)
        Case enmDateFormat.eMM_DD_YYYY
            sYear = Right(p_sSource, 4)
        Case enmDateFormat.eYYYY_MM_DD
            sYear = Left(p_sSource, 4)
        Case enmDateFormat.e1or2M_1or2D_2or4Y
            If IsDigitsOnly(Right(p_sSource, 4)) Then
                sYear = Right(p_sSource, 4)
            Else
                sYear = Right(p_sSource, 2)
            End If
        End Select
        
        If Not IsDigitsOnly(sYear) Then
            Exit Function
        Else
            p_lYear = CLng(sYear)
        End If
        
        If p_lYear < 0 Then
            Exit Function
        Else
            bReturn = True
        End If
        
        YearCheck = bReturn
        
End Function

Private Function MonthExtract(ByVal p_lMode As enmDateFormat _
                    , ByVal p_sSource As String) _
                    As Long
                    
        ' Returns month if valid, zero otherwise
        Dim lReturn As Long
        Dim sMonth As String
        
        ' extract month
        Select Case p_lMode
        Case enmDateFormat.eMM_DD_YY, enmDateFormat.eMM_DD_YYYY
            sMonth = Left(p_sSource, 2)
        Case enmDateFormat.eYYYY_MM_DD
            sMonth = Mid(p_sSource, 6, 2)
        Case enmDateFormat.e1or2M_1or2D_YY
            Select Case Len(p_sSource)
            Case 6
                sMonth = Left(p_sSource, 1)
            Case 7
                If IsDigitsOnly(Left(p_sSource, 2)) Then
                    sMonth = Left(p_sSource, 2)
                Else
                    sMonth = Left(p_sSource, 1)
                End If
            Case 8
                sMonth = Left(p_sSource, 2)
            End Select
            
        Case enmDateFormat.e1or2M_1or2D_2or4Y
            Select Case Len(p_sSource)
            Case 6
                sMonth = Left(p_sSource, 1)
            Case 10
                sMonth = Left(p_sSource, 2)
            Case Else
                If IsDigitsOnly(Left(p_sSource, 2)) Then
                    sMonth = Left(p_sSource, 2)
                Else
                    sMonth = Left(p_sSource, 1)
                End If
            End Select
        
        End Select
        
        ' Validate
        If IsDigitsOnly(sMonth) Then
            If CLng(sMonth) >= 1 And CLng(sMonth) <= 12 Then
                lReturn = CLng(sMonth)
            End If
        End If
        
        MonthExtract = lReturn
        
End Function

Private Function DayCheck(ByVal p_lMode As enmDateFormat _
                    , ByVal p_sSource As String _
                    , ByVal p_lMonth As Long _
                    , ByVal p_lYear As Long) _
                    As Long
                    
        ' Returns day if valid, zero otherwise
                    
        Dim lReturn As Long
        
        ' extract day
        Dim sDay As String
        Select Case p_lMode
        Case enmDateFormat.eMM_DD_YY, enmDateFormat.eMM_DD_YYYY
            sDay = Mid(p_sSource, 4, 2)
        Case enmDateFormat.eYYYY_MM_DD
            sDay = Mid(p_sSource, 9, 2)
        Case enmDateFormat.e1or2M_1or2D_YY
            Select Case Len(p_sSource)
            Case 8
                sDay = Mid(p_sSource, 4, 2)
            Case 6
                sDay = Mid(p_sSource, 3, 1)
            Case Else
                If IsDigitsOnly(Mid(p_sSource, 3, 2)) Then
                    sDay = Mid(p_sSource, 3, 2)
                Else
                    sDay = Mid(p_sSource, 4, 1)
                End If
            End Select
        
        Case enmDateFormat.e1or2M_1or2D_2or4Y
            Select Case Len(p_sSource)
            Case 10
                sDay = Mid(p_sSource, 4, 2)
            Case 6
                sDay = Mid(p_sSource, 3, 1)
            Case 7
                If IsDigitsOnly(Mid(p_sSource, 3, 2)) Then
                    sDay = Mid(p_sSource, 3, 2)
                Else
                    sDay = Mid(p_sSource, 4, 1)
                End If
            Case 8
                If IsDigitsOnly(Mid(p_sSource, 4, 2)) Then
                    sDay = Mid(p_sSource, 4, 2)
                Else
                    sDay = Mid(p_sSource, 3, 1)
                End If
            Case 9
                If IsDigitsOnly(Mid(p_sSource, 3, 2)) Then
                    sDay = Mid(p_sSource, 3, 2)
                Else
                    sDay = Mid(p_sSource, 4, 1)
                End If
            End Select
            
        End Select
        
        
        ' ? positve number
        If Not IsDigitsOnly(sDay) Then
            Exit Function
        Else
            Dim lDay As Long: lDay = CLng(sDay)
            If lDay < 0 Then Exit Function
        End If
        
        ' Get maximum days in the month
        Dim lMax As Long
        Select Case p_lMonth
        Case 4, 6, 9, 11
            lMax = 30
        Case 1, 3, 5, 7, 8, 10, 12
            lMax = 31
        Case 2
            If IsLeapYear(p_lYear) Then
                lMax = 29
            Else
                lMax = 28
            End If
        End Select
        
        ' showtime
        If lDay > lMax Then Exit Function
        
        DayCheck = lDay
        
End Function

Private Function IsLeapYear(p_lYear As Long)
        If (p_lYear Mod 4 = 0) And _
                ((p_lYear Mod 100 <> 0) Or (p_lYear Mod 400 = 0)) Then
        IsLeapYear = True
    Else
        IsLeapYear = False
    End If
End Function

Private Function InList(p_vCompare As Variant _
                , p_vItems_ As Variant) _
                As Boolean
    '' Returns True if 1st parameter is a member of second.

Dim lMin As Long: lMin = LBound(p_vItems_)
    Dim lMax As Long: lMax = UBound(p_vItems_)
    Dim bReturn As Boolean: bReturn = False
    Dim l As Long
    
    For l = lMin To lMax
        If p_vCompare = p_vItems_(l) Then
            bReturn = True
            Exit For
        End If
    Next
    
    InList = bReturn

End Function

Public Function IsDigitsOnly(Value As String) As Boolean
    IsDigitsOnly = Not Value Like "*[!0-9]*"
End Function