Advertisement
nandordudas

Error Handler

Jun 2nd, 2016
98
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Option Compare Binary
  2. Option Explicit
  3.  
  4. Public Function Handle(ByVal ErrorNumber As Long, _
  5.     ByVal ErrorDescription As String, Optional ByVal Custom As String, _
  6.     Optional ByVal ErrorProcedure As String, _
  7.     Optional ByVal ErrorModule As String)
  8.  
  9.     On Error GoTo Catch
  10.  
  11.     Dim ErrorMessage As String, Choice As VBA.VbMsgBoxResult
  12.  
  13.     If ("Microsoft Access" = Application.Name) Then _
  14.         Application.DoCmd.SetWarnings False
  15.  
  16.     ErrorMessage = "Error #: " & ErrorNumber _
  17.         & VBA.Constants.vbCrLf _
  18.         & "Error Description: " & ErrorDescription _
  19.         & VBA.Constants.vbCrLf _
  20.         & "Error Module: " & ErrorModule _
  21.         & VBA.Constants.vbCrLf _
  22.         & "Error Procedure: " & ErrorProcedure
  23.     ErrorMessage = IIf(("" = Custom), ErrorMessage, _
  24.         Custom & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf & ErrorMessage)
  25.  
  26.     If ("Microsoft Access" = Application.Name) Then CreateErrorTable
  27.  
  28. '   Access>File>Options>Object Designers>Query Design>
  29. '       SQL Server Compatible Syntax (ANSI 92)>This Database
  30.    If ("Microsoft Access" = Application.Name) Then
  31.         Application.DoCmd.RunSQL "INSERT INTO tblError (" _
  32.             & "ErrorNumber, " _
  33.             & "ErrorDescription, " _
  34.             & "ProcedureName, " _
  35.             & "ModuleName, " _
  36.             & "ErrorTimeStamp, " _
  37.             & "UserName, " _
  38.             & "ComputerName" _
  39.             & ") VALUES (" _
  40.             & ErrorNumber & ", " _
  41.             & "'" & VBA.Strings.Replace(ErrorDescription, "'", "''") & "', " _
  42.             & "'" & ErrorProcedure & "', " _
  43.             & "'" & ErrorModule & "', " _
  44.             & "NOW, " _
  45.             & "'" & VBA.Interaction.Environ$("USERNAME") & "', " _
  46.             & "'" & VBA.Interaction.Environ$("COMPUTERNAME") & "')"
  47.     Else
  48. '       Instant alternative. Use another file or sheet logging.
  49.        MsgBox "Error #: " & ErrorNumber _
  50.             & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
  51.             & "Error Description: " & ErrorDescription _
  52.             & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
  53.             & "Error Procedure: " & ErrorProcedure _
  54.             & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
  55.             & "Error Module: " & ErrorModule _
  56.             & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
  57.             & "Timestamp: " & VBA.DateTime.Now _
  58.             & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
  59.             & "Username: " & VBA.Interaction.Environ$("USERNAME") _
  60.             & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
  61.             & "Computername: " & VBA.Interaction.Environ$("COMPUTERNAME"), _
  62.             48, "Error"
  63.     End If
  64.  
  65.     GoTo Finally
  66.  
  67. Catch:
  68.     ErrorMessage = "This error will not be logged" _
  69.         & VBA.Constants.vbCrLf & VBA.Constants.vbCrLf _
  70.         & "Error #: " & VBA.Information.Err.Number _
  71.         & VBA.Constants.vbCrLf _
  72.         & "Error Description: " & VBA.Information.Err.Description _
  73.         & VBA.Constants.vbCrLf _
  74.         & "Error Module: " & Application.VBE.ActiveCodePane.CodeModule.Name _
  75.         & VBA.Constants.vbCrLf _
  76.         & "Error Procedure: Sub Handle"
  77.     Choice = VBA.Interaction.MsgBox(ErrorMessage, 50, "Error handling error")
  78.  
  79. #If Debugging Then
  80.  
  81. #End If
  82.  
  83.     On Error Resume Next
  84.  
  85.     Select Case Choice
  86.  
  87.         Case 5
  88.             Resume Next
  89.  
  90.         Case 4
  91.             Resume
  92.  
  93.         Case 3
  94.             GoTo Finally
  95.  
  96.         Case Else
  97.  
  98.     End Select
  99.  
  100. Finally:
  101.     If ("Microsoft Access" = Application.Name) Then _
  102.         Application.DoCmd.SetWarnings True
  103.  
  104. End Function
  105.  
  106. Private Function ErrorTableExists() As Boolean
  107.  
  108.     On Error GoTo Catch
  109.  
  110.     ErrorTableExists = VBA.Conversion.CBool(Application.DCount("[Name]", _
  111.         "MSysObjects", "[Type] = 1 AND [Name] = 'tblError'"))
  112.  
  113.     GoTo Finally
  114.  
  115. Catch:
  116.     Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
  117.         "Function ErrorTableExists", _
  118.         Application.VBE.ActiveCodePane.CodeModule.Name
  119.  
  120. Finally:
  121.  
  122. End Function
  123.  
  124. Private Sub CreateErrorTable()
  125.  
  126.     On Error GoTo Catch
  127.  
  128.     If ErrorTableExists Then GoTo Finally
  129.  
  130.     Application.DoCmd.RunSQL "CREATE TABLE tblError (" _
  131.         & "ErrorId AUTOINCREMENT(1, 1) PRIMARY KEY, " _
  132.         & "ErrorNumber INTEGER NOT NULL, " _
  133.         & "ErrorDescription LONGTEXT NOT NULL, " _
  134.         & "ProcedureName VARCHAR NOT NULL, " _
  135.         & "ModuleName VARCHAR NOT NULL, " _
  136.         & "ErrorTimeStamp DATETIME NOT NULL, " _
  137.         & "UserName VARCHAR NOT NULL, " _
  138.         & "ComputerName VARCHAR NOT NULL)"
  139.  
  140.     GoTo Finally
  141.  
  142. Catch:
  143.     Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
  144.         "Sub CreateErrorTable", _
  145.         Application.VBE.ActiveCodePane.CodeModule.Name
  146.  
  147. Finally:
  148.  
  149. End Sub
  150.  
  151. Private Sub TruncateErrorTable()
  152.  
  153.     On Error GoTo Catch
  154.  
  155.     If Not ErrorTableExists Then GoTo Finally
  156.  
  157.     Application.DoCmd.Close 0, "tblError", 1
  158.     Application.DoCmd.RunSQL "DELETE FROM tblError", 128
  159.     Application.DoCmd.RunSQL "ALTER TABLE tblError ALTER COLUMN ErrorId " _
  160.         & "COUNTER (1, 1)"
  161.  
  162.     GoTo Finally
  163.  
  164. Catch:
  165.     Handle VBA.Information.Err.Number, VBA.Information.Err.Description, "", _
  166.         "Sub TruncateErrorTable", _
  167.         Application.VBE.ActiveCodePane.CodeModule.Name
  168.  
  169. Finally:
  170.  
  171. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement