military time function error

sassriverrat

Well-known Member
Joined
Oct 4, 2018
Messages
617
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!

Code:
 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
 

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

MARK858

MrExcel MVP
Joined
Nov 12, 2010
Messages
12,013
Office Version
365, 2010
Platform
Windows, Mobile
You need to also post the code for the Sub Error_Handle :biggrin:
 

sassriverrat

Well-known Member
Joined
Oct 4, 2018
Messages
617
You need to also post the code for the Sub Error_Handle :biggrin:
Here's all of it
Code:
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
 

Forum statistics

Threads
1,089,270
Messages
5,407,302
Members
403,131
Latest member
Lewas2019

This Week's Hot Topics

Top