This VBA snippet will execute the following actions:
- Save error details in tblErrorLog table
- It will add the current method if it does not exist in tblVBAMethods table
- Allow user to report the error which by sending an email with screen dump taken and attached automatically
The script is referencing the following tables:
CREATE TABLE tblErrorLog(
ErrorID LONG AUTOINCREMENT,
MethodID TEXT(255) NOT NULL,
LineNo LONG NOT NULL,
ErrorNo LONG NOT NULL,
ErrorDescription MEMO NOT NULL,
DateCreated DATETIME NOT NULL,
CreatedBy TEXT(255) NOT NULL,
DateModified DATETIME,
ModifiedBy TEXT(255)
);
CREATE TABLE tblVBAMethods(
MethodID TEXT(255) NOT NULL,
Component TEXT(100) NOT NULL,
Method TEXT(100) NOT NULL,
DateCreated DATETIME NOT NULL,
CreatedBy TEXT(255) NOT NULL,
DateModified DATETIME,
ModifiedBy TEXT(255)
);
CREATE TABLE tblVBAComponents(
Component TEXT(100) NOT NULL,
IsSelected BOOL,
DateCreated DATETIME NOT NULL,
CreatedBy TEXT(255) NOT NULL,
DateModified DATETIME,
ModifiedBy TEXT(255)
);
CREATE TABLE tblAppSettings(
ConstID TEXT(255) NOT NULL,
ConstDesc TEXT(255) NOT NULL,
ConstValue TEXT(255) NOT NULL,
DateCreated DATETIME NOT NULL,
CreatedBy TEXT(255) NOT NULL,
DateModified DATETIME,
ModifiedBy TEXT(255)
);
Option Compare Database
Option Explicit
Option Base 1
Function TestErrorMessage()
On Error GoTo ErrorExit
Dim RaiseVal As Integer
10 RaiseVal = 1 / 0
NormalExit:
Exit Function
ErrorExit:
ErrNumber = Err.Number: ErrDescription = Err.Description: LineNo = Erl
MethodID = VBE.ActiveCodePane.CodeModule.Name + "." + GetFnOrSubName(Erl)
WhereIs = "Raised on line " + IIf(CStr(LineNo) = "0", "Unknown", CStr(LineNo)) + " of " + MethodID + " method."
ErrorPrompt = "Error " + CStr(ErrNumber) + " - " + ErrDescription
ErrorID = LogError(MethodID, LineNo, ErrNumber, ErrDescription)
Answer = MsgBox(WhereIs + ". " + vbCr + vbCr + "Do you want to report it?", (vbCritical + vbQuestion + vbYesNo + vbDefaultButton2), ErrorPrompt)
If Answer = vbYes Then Call ReportError(ErrorID): Resume NormalExit
End Function
Function LogError(MethodID As String, LineNo As Variant, ErrNumber As Integer, ErrDescription As String) As Long
On Error GoTo ErrorExit
Dim strMsg As String, strSql As String, ErrorID As Long, StartDateTime As Date, strWhere As String, MethodCounter As Integer _
, Scope As String, Component As String, Method As String
StartDateTime = Now()
LogError = 0
Call InitApp
MethodCounter = DCount("*", "tblVBAMethods", "MethodID = '" + MethodID + "'")
If MethodCounter = 0 Then
Scope = VBE.ActiveCodePane.CodeModule.Name
Component = VBE.SelectedVBComponent.Name
Method = Mid(MethodID, InStr(1, MethodID, ".") + 1, Len(MethodID))
Call AddMethod(MethodID, Scope, Component, Method, SeekerEmail, StartDateTime)
End If
strSql = "INSERT INTO tblErrorLog ( MethodID, LineNo, ErrorNo, ErrorDeScription, DateCreated, CreatedBy)"
strSql = strSql + " VALUES('" + MethodID + "'"
strSql = strSql + ", '" + CStr(LineNo) + "'"
strSql = strSql + ", '" + CStr(ErrNumber) + "'"
strSql = strSql + ", '" + ErrDescription + "'"
strSql = strSql + ", '" + CStr(StartDateTime) + "'"
strSql = strSql + ", '" + SeekerEmail + "')"
DoCmd.SetWarnings False
DoCmd.RunSQL strSql
DoCmd.SetWarnings True
strWhere = "CStr(DateCreated) = '" + CStr(StartDateTime) + "' and CreatedBy = '" + SeekerEmail + "'"
LogError = DLookup("ErrorID", "tblErrorLog", strWhere)
NormalExit:
Exit Function
ErrorExit:
ErrNumber = Err.Number: ErrDescription = Err.Description: LineNo = Erl
MethodID = VBE.ActiveCodePane.CodeModule.Name + "." + GetFnOrSubName(Erl)
WhereIs = "Raised on line " + IIf(CStr(LineNo) = "0", "Unknown", CStr(LineNo)) + " of " + MethodID + " method."
ErrorPrompt = "Error " + CStr(ErrNumber) + " - " + ErrDescription
ErrorID = LogError(MethodID, LineNo, ErrNumber, ErrDescription)
Answer = MsgBox(WhereIs + ". " + vbCr + vbCr + "Do you want to report it?", (vbCritical + vbQuestion + vbYesNo + vbDefaultButton2), ErrorPrompt)
If Answer = vbYes Then Call ReportError(ErrorID): Resume NormalExit
End Function
Function ReportError(ErrorID As Long) As Boolean
On Error GoTo ErrorExit
Dim Style As Variant, Title As Variant, SupportEmail As String, RetVal As String, TestVal As Boolean, frmMsg As String _
, PowerShellFile As String, BMPfile As String, waitOnReturn As Boolean, windowStyle As Integer
ReportError = False
windowStyle = 1: waitOnReturn = True
Call PrintScreen
SupportEmail = Nz(DLookup("ConstValue", "tblAppSettings", "ConstID='SupportEmail'"), vbNullString)
PowerShellFile = Application.CurrentProject.path + "\ErrorMessages\" + SeekerEmail + "\" + "SpoolClipboardImageToBMPfile.ps1"
BMPfile = Application.CurrentProject.path + "\ErrorMessages\" + SeekerEmail + "\"
BMPfile = BMPfile + "Error_" + Format$(Now, "yyyy_mm_dd_hh_mm_ss") + ".bmp"
TestVal = SpoolClipboardImageToBMPfile(PowerShellFile, BMPfile)
If Not TestVal Then GoTo NormalExit
TestVal = SendEmail(EmailTo:=SupportEmail _
, EmailSubject:=ErrorPrompt + WhereIs _
, EmailBody:="ErrorID is " + CStr(ErrorID) _
, Attachment:=BMPfile)
Call Pause(2)
If Not TestVal Then GoTo NormalExit
TestVal = LetsDeleteFile(BMPfile)
If Not TestVal Then GoTo NormalExit
ReportError = True
NormalExit:
Exit Function
ErrorExit:
ErrNumber = Err.Number: ErrDescription = Err.Description: LineNo = Erl
MethodID = VBE.ActiveCodePane.CodeModule.Name + "." + GetFnOrSubName(Erl)
WhereIs = "Raised on line " + IIf(CStr(LineNo) = "0", "Unknown", CStr(LineNo)) + " of " + MethodID + " method."
ErrorPrompt = "Error " + CStr(ErrNumber) + " - " + ErrDescription
ErrorID = LogError(MethodID, LineNo, ErrNumber, ErrDescription)
Answer = MsgBox(WhereIs + ". " + vbCr + vbCr + "Do you want to report it?", (vbCritical + vbQuestion + vbYesNo + vbDefaultButton2), ErrorPrompt)
If Answer = vbYes Then Call ReportError(ErrorID): Resume NormalExit
End Function
Function GetFnOrSubName(handlerLabel As String) As String
On Error GoTo ErrorExit
Dim VBProj As VBIDE.VBProject, vbComp As VBIDE.VBComponent, CodeMod As VBIDE.CodeModule, code$, handlerAt&, isFunction&, isSub&
Set VBProj = VBE.ActiveVBProject
Set vbComp = VBProj.VBComponents(VBE.ActiveCodePane.CodeModule.Name)
Set CodeMod = vbComp.CodeModule
code = CodeMod.Lines(1, CodeMod.CountOfLines)
handlerAt = InStr(1, code, handlerLabel, vbTextCompare)
If handlerAt Then
isFunction = InStrRev(Mid$(code, 1, handlerAt), "Function", -1, vbTextCompare)
isSub = InStrRev(Mid$(code, 1, handlerAt), "Sub", -1, vbTextCompare)
If isFunction > isSub Then
'It's a function
GetFnOrSubName = Replace(Split(Mid$(code, isFunction, 40), "(")(0), "Function ", vbNullString)
Else
'It's a sub
GetFnOrSubName = Replace(Split(Mid$(code, isSub, 40), "(")(0), "Sub ", vbNullString)
End If
End If
NormalExit:
Exit Function
ErrorExit:
ErrNumber = Err.Number: ErrDescription = Err.Description: LineNo = Erl
MethodID = VBE.ActiveCodePane.CodeModule.Name + "." + GetFnOrSubName(Erl)
WhereIs = "Raised on line " + IIf(CStr(LineNo) = "0", "Unknown", CStr(LineNo)) + " of " + MethodID + " method."
ErrorPrompt = "Error " + CStr(ErrNumber) + " - " + ErrDescription
ErrorID = LogError(MethodID, LineNo, ErrNumber, ErrDescription)
Answer = MsgBox(WhereIs + ". " + vbCr + vbCr + "Do you want to report it?", (vbCritical + vbQuestion + vbYesNo + vbDefaultButton2), ErrorPrompt)
If Answer = vbYes Then Call ReportError(ErrorID): Resume NormalExit
End Function
Sub PrintScreen()
keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub
Function SpoolClipboardImageToBMPfile(PowerShellFile As String, BMPfile As String) As Boolean
On Error GoTo ErrorExit
Dim objWScript As Object, psCmd As String, TestVal As Integer, MkDirFavorites As String, WshExec As Object _
, waitOnReturn As Boolean, windowStyle As Integer, ErrorCode As Integer
SpoolClipboardImageToBMPfile = False
Set objWScript = CreateObject("WScript.Shell")
psCmd = "get-clipboard -format image" + vbCr
psCmd = psCmd + "$img = get-clipboard -format image" + vbCr
psCmd = psCmd + "$img.save('" + BMPfile + "')" + vbCr
TestVal = LetsDeleteFile(PowerShellFile)
If Not TestVal Then GoTo NormalExit
TestVal = LetsCreateFile(PowerShellFile, psCmd)
If Not TestVal Then GoTo NormalExit
psCmd = "Powershell -File """ + PowerShellFile + """"
ErrorCode = objWScript.Run(psCmd, vbHide, waitOnReturn)
If ErrorCode > 0 Then GoTo NormalExit
SpoolClipboardImageToBMPfile = True
NormalExit:
Set objWScript = Nothing
Exit Function
ErrorExit:
ErrNumber = Err.Number: ErrDescription = Err.Description: LineNo = Erl
MethodID = VBE.ActiveCodePane.CodeModule.Name + "." + GetFnOrSubName(Erl)
WhereIs = "Raised on line " + IIf(CStr(LineNo) = "0", "Unknown", CStr(LineNo)) + " of " + MethodID + " method."
ErrorPrompt = "Error " + CStr(ErrNumber) + " - " + ErrDescription
ErrorID = LogError(MethodID, LineNo, ErrNumber, ErrDescription)
Answer = MsgBox(WhereIs + ". " + vbCr + vbCr + "Do you want to report it?", (vbCritical + vbQuestion + vbYesNo + vbDefaultButton2), ErrorPrompt)
If Answer = vbYes Then Call ReportError(ErrorID): Resume NormalExit
End Function
If you find this script useful please donate generously.
