military time function error

[sassriverrat]

Good Morning,

A user made this (and I just contributed) probably a year ago and I've been fighting a bug in it. I have a userform that inputs data (in a halfway pretty GUI) in appropriate cells on a sheet. The user is supposed to be able to input, say, 0900, 9:00, or any "theoretical" method of typing in a time into the userform or into the cell itself and it should be corrected to a properly formatted time. Well it seems that inputting, say 0412 or 0400, certain times work fine, yet if start to input 090, the code below errors twice in a row here, regardless of what the last digit might be in an attempt to input 0900. And after denying the error twice, when I input the last 0, so 0900, it will error a third time. Not sure why this specific time does it, but it is consistent!

 Function MilitarytoTime(Miltime As String) As Date

'Begins Error Handling Code
On Error GoTo Helper


If Miltime <> "" Then
    MilitarytoTime = Format(Replace(Miltime, ":", ""), "00:00")
End If


'Error Clearing Code
Exit Function
Helper:
    resp = MsgBox("We're sorry to see you've encountered an error." & vbCrLf & vbCrLf & "To proceed, we recommend you contact the Developer " & _
    "with error codes [1131] and " & "[" & Err.Number & "-" & Err.Description & "]." & vbCrLf & vbCrLf & "To attempt to patch your problem at least " & _
    "temporarily, we recommend you click [Yes] to see help directions. Would you like to continue?", vbYesNoCancel, name)
        If resp = vbYes Then
            Call Error_Handle(sprocname, Err.Number, Err.Description)
        ElseIf resp = vbNo Then
            Exit Function
        ElseIf resp = vbCancel Then
            Exit Function
        End If
        
End Function

 

[MARK858]

You need to also post the code for the Sub Error_Handle

 

[sassriverrat]

You need to also post the code for the Sub Error_Handle

Here's all of it

Option Explicit 
Enum W32_Window_State
    Show_Normal = 1
    Show_Minimized = 2
    Show_Maximized = 3
    Show_Min_No_Active = 7
    Show_Default = 10
End Enum
 
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
 
Function OpenURL(URL As String, WindowState As W32_Window_State) As Boolean
     
    'Opens passed URL with default application, or Error Code (<32) upon error
     
    Dim lngHWnd As Long
    Dim lngReturn As Long
     
    lngReturn = ShellExecute(lngHWnd, "open", URL, vbNullString, _
    vbNullString, WindowState)
     
    OpenURL = (lngReturn > 32)
     
End Function




Sub Open_error_log()
Dim name As String
    name = Sheets("Notes").Range("N4")
Dim path1 As String
Dim path2 As String
Dim strfilepath1 As String
    With Sheets("Developer")
        path1 = .Range("E44")
        path2 = .Range("J44")
    End With
    strfilepath1 = path1 & "\" & path2 & ".txt"
If Dir(strfilepath1) <> "" Then
    OpenURL (strfilepath1), Show_Maximized
Else: MsgBox "An Error Log currently does not exist", vbOKOnly, name
End If
End Sub




Public Sub Error_Handle(ByVal sRoutineName As String, _
                         ByVal sErrorNo As String, _
                         ByVal sErrorDescription As String)
Dim sMessage As String
   sMessage = sErrorNo & " - " & sErrorDescription
   'Call MsgBox(sMessage, vbCritical, sRoutineName & " - Error")
   With UserForm18
        .Label4.Caption = sRoutineName & " [" & sMessage & "]"
        .Show
    End With
   Call LogFile_WriteError(sRoutineName, sMessage)
End Sub






Public Function LogFile_WriteError(ByVal sRoutineName As String, _
                             ByVal sMessage As String)


Dim g_objFSO As Object
Dim g_scrText As Object
Set g_objFSO = CreateObject("Scripting.FileSystemObject")
Dim sText As String
Dim errdrive As String
Dim erraddress As String
errdrive = Sheets("Developer").Range("E44")
erraddress = Sheets("Developer").Range("J44")
Dim name As String
    name = Sheets("Notes").Range("N4")


errfile = errdrive & "\" & erraddress & ".txt"
   'On Error GoTo ErrorHandler
   
   If (g_scrText Is Nothing) Then
      If (g_objFSO.FileExists(errfile) = False) Then
         Set g_scrText = g_objFSO.OpenTextFile(errfile, 2, True)
      Else
         Set g_scrText = g_objFSO.OpenTextFile(errfile, 8)
      End If
   End If
   sText = sText & "" & vbCrLf
   sText = sText & Format(Date, "dd MMM yyyy") & "-" & Time() & vbCrLf
   sText = sText & " " & sRoutineName & vbCrLf
   sText = sText & " " & sMessage & vbCrLf
   g_scrText.WriteLine sText
   g_scrText.Close
   Set g_scrText = Nothing
   Exit Function
'ErrorHandler:
   Set g_scrText = Nothing
   Call MsgBox("Unable to write to log file", vbCritical, name)
End Function