Error Checking Of Time Value With Function Causing Grave Problems

[Ark68]

I have run into a debilitating problem that has left me stumped and my project unable to proceed with its development. I will try to explain.

A userform (uf6_trn_reline) is opened.
It consists of two textboxes, tb_r1_sru and tb_r1_srl. These boxes allow the user to enter time values to define the bounds of a range of time. 'sru1' is the lower time and 'srl1' is the upper time of the range (I know ... backwards). That being said, 'srl1' has to be greater than 'sru1' to ensure there is a proper period between the two times.

The values have to be entered in 24hr format to be properly assessed as being a time value. 'srl' remains locked until a proper value is entered by the user. Once that value is obtained, 'srl' gets automatically populated with a defualt value 30 minutes greater than 'sru'. The user is able to overwrite that value if she sees fit.

Suppose the user enters 14:00 (2:00 PM) into 'sru1'.

Private Sub tb_r1_sru_BeforeUpdate(ByVal CANCEL As MSForms.ReturnBoolean)
    
    Me.cb_r1_crew.Enabled = False
    Me.tb_r1_sru.BackColor = RGB(255, 255, 255)
    
    Call CheckEntry(tb_r1_sru, CANCEL)
    If gflag <> 1 Then Exit Sub 'if time entry (module 11} if invalid
    If CDate(Me.tb_r1_sru.Value) < CDate(ws_data.Range("N" & rn)) Or CDate(Me.tb_r1_sru.Value) > CDate(ws_data.Range("O" & rn)) Then
        MsgBox "The service time provided does not fall within the rental period (" & Format(ws_data.Range("N" & rn), "h:mm AM/PM") & " - " & Format(ws_data.Range("O" & rn), "h:mm AM/PM") & ")" & Chr(13) & "Please re-enter an appropriate time within this range.", vbCritical, "INVALID ENTRY"
        Me.tb_r1_sru.Value = ""
        Me.tb_r1_sru.BackColor = RGB(0, 126, 167) 'RGB(245, 81, 78)
        Me.tb_r1_sru.SetFocus
        CANCEL = True
        Exit Sub
    End If
    Me.tb_r1_srl.Value = Format(CDate(Me.tb_r1_sru.Value) + TimeSerial(0, 30, 0), "h:mm AM/PM")
    Me.tb_r2_sru.Locked = False
    Me.cb_r1_crew.Enabled = True
    If Me.ob_r1_reline = False Then
        Me.cb_r1_base.Enabled = True
        Me.cb_r1_pitch.Enabled = True
    End If
    
End Sub

Upon entry, procedure 'CheckEntry' is called. This procedure checks whether or not a time value has been entered.

Sub CheckEntry(aTextBox As MSForms.TextBox, ByVal CANCEL As MSForms.ReturnBoolean)
    Dim crew1 As String
    Dim t As Date
    Dim min_time_limit As Date
    Dim max_time_limit  As Date
    Dim sTime As String
    
    If mbEvents Then Exit Sub
    
    min_time_limit = TimeValue("5:30 AM")
    max_time_limit = TimeValue("5:00 PM")

    With aTextBox
                If Len(aTextBox) < 1 Then
            sTime = ""
        Else
            sTime = GetTime(.Text)
        End If
        If sTime = "" Then 'invalid
            mbEvents = False
            errorcap1a = "Invaid time entry. Please retry."
            errorcap1b = "Enter time in 24H format (hh:mm)."
            'MsgBox "Enter time in 24H format (hh:mm)." & Chr(13) & "Please retry.", vbExclamation, "INVALID TIME ENTRY"
            nt_invalid_time_entry.Show
            CANCEL = True
            .Value = ""
            .BackColor = RGB(0, 126, 167)
            .TabIndex = 0
            .SetFocus
            gflag = 0
            mbEvents = False
            Exit Sub
        Else
            .BackColor = RGB(255, 255, 255)
        End If
        
        .Text = Format(sTime, "h:mm AM/PM")
        
    End With
    gflag = 1 'time entry valid
    
End Sub

Function GetTime(ByVal sTime As String) As Variant
    Dim vparts
    Dim ap As String
    vparts = VBA.Split(sTime, ":")
    If UBound(vparts) < 1 Then
        sTime = vparts(0) & ":00"
    Else
        If Len(vparts(1)) <> 2 Then vparts(1) = VBA.Left$(vparts(1) & "00", 2)
    End If
    sTime = VBA.Join(vparts, ":")

    If IsDate(sTime) Then
        GetTime = TimeValue(sTime)
    Else
        GetTime = ""
    End If
End Function

The user's entry of 14:00 passes through the CheckEntry as being a valid time. With a return back to 'Sub tb_r1_sru_BeforeUpdate' , another error check specific to the application is made, and the value of 14:00 passes it.

'tb_r1_srl' is auto populated with a value 30 minutes greater than 14:00. I confirm the textbox populates with '2:30 PM'. This is correct.

At this point, 'Sub tb_r1_srl_beforeupdate' is tiggered.

Private Sub tb_r1_srl_beforeupdate(ByVal CANCEL As MSForms.ReturnBoolean)
    
    Me.tb_r1_srl.BackColor = RGB(255, 255, 255)
    
    Call CheckEntry(tb_r1_srl, CANCEL)
    If gflag <> 1 Then Exit Sub 'if time entry (module 11} if invalid
    If CDate(tb_r1_srl.Value) < TimeValue(tb_r1_sru.Value) Then
        MsgBox "The upper range limit must be later than the lower range limit." & Chr(13) & "Please re-enter a time greater than " & tb_r1_sru.Value
        Application.EnableEvents = False
        
        Me.tb_r1_srl.Value = Format(TimeValue(Me.tb_r1_sru.Value) + TimeSerial(0, 30, 0), "h:mm AM/PM")
        
        Me.tb_r1_srl.SetFocus
        CANCEL = True
 
    End If
    Me.rrl_submit.Enabled = True
End Sub

This is where things fall apart .... somewhere 'tb_r1_srl.Value' changes from 2:30PM to 2:30AM. As a result the 'If CDate(tb_r1_srl.Value) < TimeValue(tb_r1_sru.Value) Then' condition is met advising the used of the time discrepencies. 'tb_r1_srl.Value' is reset to the default of 'sru' +30 minutes. Now ... it's just an endless loop. I am unable to keep 'srl' = 2:30PM, it always wants to be 2:30AM.

The interesting thing, is I can enter any value less than and equal to 12:00PM (8:00AM, 9:00AM, 11:30AM etc) into ''tb_r1_sru' and everything works flawlessly.

When I step through the code, I discover it's in 'CheckEntry' routine where the change is being made, more specifically the 'GetTime' function it calls. With the line in green in CheckEntry, '.text'=2:30 PM. sTime represented the green line of the GetTime function = 2:30 PM. The value for sTime in the blue line (Of GetTime) is simple "2:30"). And finally, the line in red, is where the time changes to 2:30 AM.

I realize this may be pretty messed up, but is there a way I can correct this oversight. I a have a feeling the 'CheckEntry' routine only checks the format of the entry to see if its a time and shouldn't be used in the calculation of times.

Thank you all in advance for your time.

 

[Ark68]

Took a lot of trial and error but found a solution.

 

[Snakehips]

Good to hear.
Was just about to post this which should sort it...

Function GetTime(ByVal sTime As String) As Variant
    Dim vparts
    Dim ap As String
    vparts = VBA.Split(sTime, ":")
    If UBound(vparts) < 1 Then sTime = vparts(0) & ":00"
   
    sTime = VBA.Join(vparts, ":")
    
    GetTime = CDate(sTime) '*****************


    If IsDate(sTime) Then
        GetTime = TimeValue(sTime)
    Else
        GetTime = ""
    End If


End Function

 

[Ark68]

Hi Snakehips ...

Thank you taking a stab at this on my behalf. The effort is appreciated!

You solution looks quite a bit more simpler than mine. I just avoided checking 'tb_r1_srl" altogether when the time was created by default. Since it wasn't questionable whether it would be a legit time, I just bypassed the checking.

 

[Ark68]

Hi Tony,

Turns out my way only caused more problems down the road. I tried your change, but regrettably it still reads through as 2:30AM.

 

[Snakehips]

I've just mocked up a form to partially represent your situation as I see it.

The following codes still have lines that I needed to rem out so I could keep it simple. Red lines
I think I only added / changed the blue lines.
As is, it appears to work for me. Remove the rems to beef it back up then try it and let me know.

Private Sub tb_r1_srl_beforeupdate(ByVal CANCEL As MSForms.ReturnBoolean)
    
    Me.tb_r1_srl.BackColor = RGB(255, 255, 255)
    
    Call CheckEntry(tb_r1_srl, CANCEL)
    If gflag <> 1 Then Exit Sub 'if time entry (module 11} if invalid
    
    If CDate(tb_r1_srl.Value) < TimeValue(tb_r1_sru.Value) Then
        MsgBox "The upper range limit must be later than the lower range limit." & Chr(13) & "Please re-enter a time greater than " & tb_r1_sru.Value
        Application.EnableEvents = False
        
        Me.tb_r1_srl.Value = Format(TimeValue(Me.tb_r1_sru.Value) + TimeSerial(0, 30, 0), "h:mm AM/PM")
        Application.EnableEvents = True
        Me.tb_r1_srl.SetFocus
        CANCEL = True
 
    End If
    
  [COLOR=#0000ff] gflag = 0  ''******  I needed this ??????????????????????[/COLOR]
   
    'Me.rrl_submit.Enabled = True
End Sub

Private Sub tb_r1_sru_BeforeUpdate(ByVal CANCEL As MSForms.ReturnBoolean)
    
   [COLOR=#ff0000] 'Me.cb_r1_crew.Enabled = False[/COLOR]
    Me.tb_r1_sru.BackColor = RGB(255, 255, 255)
    
    Call CheckEntry(tb_r1_sru, CANCEL)
    If gflag <> 1 Then Exit Sub 'if time entry (module 11} if invalid
   [COLOR=#ff0000] 'If CDate(Me.tb_r1_sru.Value) < CDate(ws_data.Range("N" & rn)) Or CDate(Me.tb_r1_sru.Value) > CDate(ws_data.Range("O" & rn)) Then
        'MsgBox "The service time provided does not fall within the rental period (" & Format(ws_data.Range("N" & rn), "h:mm AM/PM") & " - " & Format(ws_data.Range("O" & rn), "h:mm AM/PM") & ")" & Chr(13) & "Please re-enter an appropriate time within this range.", vbCritical, "INVALID ENTRY"
       ' Me.tb_r1_sru.Value = ""
        'Me.tb_r1_sru.BackColor = RGB(0, 126, 167) 'RGB(245, 81, 78)
        'Me.tb_r1_sru.SetFocus
        'CANCEL = True
        'Exit Sub
    'End If[/COLOR]
    
    Me.tb_r1_srl.Value = Format(CDate(Me.tb_r1_sru.Value) + TimeSerial(0, 30, 0), "h:mm AM/PM")
    
    [COLOR=#ff0000]'Me.tb_r2_sru.Locked = False
    'Me.cb_r1_crew.Enabled = True
    'If Me.ob_r1_reline = False Then
        'Me.cb_r1_base.Enabled = True
        'Me.cb_r1_pitch.Enabled = True
    'End If[/COLOR]
   
End Sub

Function GetTime(ByVal sTime As String) As Variant
    Dim vparts
    Dim ap As String
    vparts = VBA.Split(sTime, ":")
    
    If UBound(vparts) < 1 Then sTime = vparts(0) & ":00"
   
    sTime = VBA.Join(vparts, ":")
    [COLOR=#0000ff]On Error Resume Next  '***************
    GetTime = CDate(sTime) '*****************
    On Error GoTo 0   '***************[/COLOR]
    If IsDate(sTime) Then
        GetTime = TimeValue(sTime)
    Else
        GetTime = ""
    End If


End Function

Sub CheckEntry(aTextBox As MSForms.TextBox, ByVal CANCEL As MSForms.ReturnBoolean)
    Dim crew1 As String
    Dim t As Date
    Dim min_time_limit As Date
    Dim max_time_limit  As Date
    Dim sTime As String
    
    If mbEvents Then Exit Sub
    
    min_time_limit = TimeValue("5:30 AM")
    max_time_limit = TimeValue("5:00 PM")


    With aTextBox
                If Len(aTextBox) < 1 Then
            sTime = ""
        Else
            sTime = GetTime(.Text)
        End If
        If sTime = "" Then 'invalid
            mbEvents = False
            errorcap1a = "Invaid time entry. Please retry."
            errorcap1b = "Enter time in 24H format (hh:mm)."
            MsgBox "Enter time in 24H format (hh:mm)." & Chr(13) & "Please retry.", vbExclamation, "INVALID TIME ENTRY"
            [COLOR=#ff0000]'nt_invalid_time_entry.Show[/COLOR]
            CANCEL = True
            .Value = ""
            .BackColor = RGB(0, 126, 167)
            .TabIndex = 0
            .SetFocus
            gflag = 0
            mbEvents = False
            Exit Sub
        Else
            .BackColor = RGB(255, 255, 255)
        End If
        
        .Text = Format(sTime, "h:mm AM/PM")
        
    End With
  gflag = 1 'time entry valid
    
End Sub