Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Option Compare Binary
- Option Explicit
- Public Function Handle(ByVal ErrorNumber As Long, _
- ByVal ErrorDescription As String, Optional ByVal Custom As String, _
- Optional ByVal ErrorProcedure As String, _
- Optional ByVal ErrorModule As String)
- On Error GoTo Catch
- Dim ErrorMessage As String, Choice As VBA.VbMsgBoxResult
- If ("Microsoft Access" = Application.Name) Then _
- Application.DoCmd.SetWarnings False
- ErrorMessage = "Error #: " & ErrorNumber _
- & VBA.Constants.vbCrLf _
- & "Error Description: " & ErrorDescription _
- & VBA.Constants.vbCrLf _
- & "Error Module: " & ErrorModule _
- & VBA.Constants.vbCrLf _
- & "Error Procedure: " & ErrorProcedure
- ErrorMessage = IIf(("" = Custom), ErrorMessage, _
- Custom & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf & ErrorMessage)
- If ("Microsoft Access" = Application.Name) Then CreateErrorTable
- ' Access>File>Options>Object Designers>Query Design>
- ' SQL Server Compatible Syntax (ANSI 92)>This Database
- If ("Microsoft Access" = Application.Name) Then
- Application.DoCmd.RunSQL "INSERT INTO tblError (" _
- & "ErrorNumber, " _
- & "ErrorDescription, " _
- & "ProcedureName, " _
- & "ModuleName, " _
- & "ErrorTimeStamp, " _
- & "UserName, " _
- & "ComputerName" _
- & ") VALUES (" _
- & ErrorNumber & ", " _
- & "'" & VBA.Strings.Replace(ErrorDescription, "'", "''") & "', " _
- & "'" & ErrorProcedure & "', " _
- & "'" & ErrorModule & "', " _
- & "NOW, " _
- & "'" & VBA.Interaction.Environ$("USERNAME") & "', " _
- & "'" & VBA.Interaction.Environ$("COMPUTERNAME") & "')"
- Else
- ' Instant alternative. Use another file or sheet logging.
- MsgBox "Error #: " & ErrorNumber _
- & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
- & "Error Description: " & ErrorDescription _
- & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
- & "Error Procedure: " & ErrorProcedure _
- & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
- & "Error Module: " & ErrorModule _
- & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
- & "Timestamp: " & VBA.DateTime.Now _
- & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
- & "Username: " & VBA.Interaction.Environ$("USERNAME") _
- & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
- & "Computername: " & VBA.Interaction.Environ$("COMPUTERNAME"), _
- 48, "Error"
- End If
- GoTo Finally
- Catch:
- ErrorMessage = "This error will not be logged" _
- & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
- & "Error #: " & VBA.Information.Err.Number _
- & VBA.Constants.vbCrLf _
- & "Error Description: " & VBA.Information.Err.Description _
- & VBA.Constants.vbCrLf _
- & "Error Module: " & Application.VBE.ActiveCodePane.CodeModule.Name _
- & VBA.Constants.vbCrLf _
- & "Error Procedure: Sub Handle"
- Choice = VBA.Interaction.MsgBox(ErrorMessage, 50, "Error handling error")
- #If Debugging Then
- #End If
- On Error Resume Next
- Select Case Choice
- Case 5
- Resume Next
- Case 4
- Resume
- Case 3
- GoTo Finally
- Case Else
- End Select
- Finally:
- If ("Microsoft Access" = Application.Name) Then _
- Application.DoCmd.SetWarnings True
- End Function
- Private Function ErrorTableExists() As Boolean
- On Error GoTo Catch
- ErrorTableExists = VBA.Conversion.CBool(Application.DCount("[Name]", _
- "MSysObjects", "[Type] = 1 AND [Name] = 'tblError'"))
- GoTo Finally
- Catch:
- Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
- "Function ErrorTableExists", _
- Application.VBE.ActiveCodePane.CodeModule.Name
- Finally:
- End Function
- Private Sub CreateErrorTable()
- On Error GoTo Catch
- If ErrorTableExists Then GoTo Finally
- Application.DoCmd.RunSQL "CREATE TABLE tblError (" _
- & "ErrorId AUTOINCREMENT(1, 1) PRIMARY KEY, " _
- & "ErrorNumber INTEGER NOT NULL, " _
- & "ErrorDescription LONGTEXT NOT NULL, " _
- & "ProcedureName VARCHAR NOT NULL, " _
- & "ModuleName VARCHAR NOT NULL, " _
- & "ErrorTimeStamp DATETIME NOT NULL, " _
- & "UserName VARCHAR NOT NULL, " _
- & "ComputerName VARCHAR NOT NULL)"
- GoTo Finally
- Catch:
- Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
- "Sub CreateErrorTable", _
- Application.VBE.ActiveCodePane.CodeModule.Name
- Finally:
- End Sub
- Private Sub TruncateErrorTable()
- On Error GoTo Catch
- If Not ErrorTableExists Then GoTo Finally
- Application.DoCmd.Close 0, "tblError", 1
- Application.DoCmd.RunSQL "DELETE FROM tblError", 128
- Application.DoCmd.RunSQL "ALTER TABLE tblError ALTER COLUMN ErrorId " _
- & "COUNTER (1, 1)"
- GoTo Finally
- Catch:
- Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
- "Sub TruncateErrorTable", _
- Application.VBE.ActiveCodePane.CodeModule.Name
- Finally:
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement