Emailing Errors Automatically

I have solved a problem that I thought would be a helpful tool to share. As a database manager I want to know when an error occurs in the database. I have built a function (with the help of shared code) that emails the error to me without disrupting the flow of work for the user. Here you go.

Place this code in your sub routine:

Private Sub Whatever()

On Error GoTo errHandler

Code goes here.

errHandler:
strErrNum = Err.Number
strErrDesc = Err.Description

Call EmailError(strErrNum, strErrDesc)

End Sub
_______________________________________________

Place this code in a module:

Option Compare Database
Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Declare Function GetActiveWindow Lib "user32.dll" () As Long
Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long

Global booIsThisOpen As Boolean
Global strIsThisopen As String

Public Function EnumWindowsProc(ByVal hwnd As Long, ByVal lParam As Long) As Long

On Error Resume Next

Dim slength As Long, TitleBar As String
Dim retval As Long
Static winnum As Integer

booIsThisOpen = False
winnum = winnum + 1
slength = GetWindowTextLength(hwnd) + 1

If slength > 1 Then
TitleBar = Space(slength)
retval = GetWindowText(hwnd, TitleBar, slength)
If InStr(TitleBar, strIsThisopen) Then
booIsThisOpen = True
Exit Function
End If
End If

EnumWindowsProc = 1

End Function

Public Function EmailError(strErrNum, strErrDesc)

Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem

'Checks to see if Outlook is running.
strIsThisopen = "Microsoft Outlook"
Call EnumWindows(AddressOf EnumWindowsProc, 0)

'If Outook is not open.
If booIsThisOpen = False Then

'Creates an instance of Outlook.
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)

'Creates and sends email.
With objEmail
.Importance = olImportanceHigh
.To = "emailme@here.com"
.Subject = "Database Error."
.Body = "The following error occurred in the database at " & Now & ": " & "'Error Number: " & strErrNum & ", Error Description: " & strErrDesc & "'."
.Send
End With

'Closes Outlook
objOutlook.Quit

'If outlook is open.
Else

'Creates an instance of Outlook.
Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)

'Creates and sends email.
With objEmail
.Importance = olImportanceHigh
.To = "emailme@here.com"
.Subject = "Database Error."
.Body = "The following error occurred in the database at " & Now & ": " & "'Error Number: " & strErrNum & ", Error Description: " & strErrDesc & "'."
.Send
End With
End If

Set objEmail = Nothing

Exit Function

End Function
_______________________________________________

The error trap calls the function "EmailError" and passes the error number and description to the email body. The function then checks to see if outlook is open. Whether Outlook is open or closed this code sends the email and returns Outlook to its prior status,opened or closed.

Place your specific information in the code where you see italics.

Good Luck,

Turbo

"There is a fine line between confidence and conceit" - Ken Mai