Attribute VB_Name = "basErrorHandler"
Option Compare Database
Option Explicit

Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
            ByVal dwFlags As Long, ByVal dwExtraInfo As Long)


Sub StandardError(Optional strObjectName, Optional strControlName)
Dim strUserNotes As String
'__________________________________________________________________________________________
'Purpose    : To create a complete error trapping routine
'Created By : {Coders Name Here}
'Created On : {Date the module was written}
'Usage Note : Review comments on each module
'Copyright  : Copyright is retained by {The Author} and this statement must be retained
'             in any use of this module
'Change Log : Last Updated On {Date Here}
'             Last Updated By {Name Here}
'             Reason For Modifications {Details here}
'
'How to Use : N/A
'__________________________________________________________________________________________


    Select Case Err.Number
        Case Else
            'To add users notes to an erorr log use the following...
            '________________________________________________________________________________________________________
            strUserNotes = InputBox("The following error has occured : " & vbCr & _
                            Err.Number & ":" & Err.Description & vbCr & vbCr & _
                            "If you provide any further information regarding this error please enter it now", _
                            "An Error has occured")
                    
            'log the error
            DoCmd.Hourglass True 'Change Cursor to an Hourglass Shape
            
            Application.SysCmd acSysCmdSetStatus, "Creating Log(1)"
            Call LogErrToTable(strUserNotes, strObjectName, strControlName)
            
            Application.SysCmd acSysCmdSetStatus, "Creating Log(2)"
            Call LogErrToText(strUserNotes, Err.Number, Err.Description, strObjectName, strControlName)
            
            Application.SysCmd acSysCmdSetStatus, "Capturing ScreenShot"
            Call GetScreenShot(strUserNotes, Err.Number, Err.Description, strObjectName, strControlName)
            
            Application.SysCmd acSysCmdSetStatus, "Generating Email)"
            Call EmailErrDetails
            
            DoCmd.Hourglass False 'Change Cursor to an normal Shape
            Application.SysCmd acSysCmdClearStatus 'clear the status bar text
    End Select

End Sub

Sub LogErrToTable(strUserNotes As String, Optional strObjectName, Optional strControlName)
Dim strSQL As String

'__________________________________________________________________________________________
'Purpose    : To Log any errors that occur to a table to enable review and determine if the
'             The Error is a USER, PC or SYSTEM error.  As a result take appropriate action
'Created By : {Coders Name Here}
'Created On : {Date the module was written}
'Usage Note : MUST have a table named 'tblErrorLog' with the following fields
'             ErrNum(Number);ErrDesc(Text-255Chars), ErrDate(Date),ErrPCName(Text),
'             ErrNotes(Memo),ObjectName(Text),ControlName(Text)
'Copyright  : Copyright is retained by {The Author} and this statement must be retained
'             in any use of this module
'Change Log : Last Updated On {Date Here}
'             Last Updated By {Name Here}
'             Reason For Modifications {Details here}
'
'How to Use : When calling this procedure the following are required elements:
'             'User Notes'
'             Optional elements help provide extended data trapping and include:
'             'ObjectName' (the Form/Report name) and 'ControlName' (the field name)
'__________________________________________________________________________________________


    strSQL = "INSERT INTO tblErrorLog ( ErrNum, ErrDesc, ErrDate, ErrUserName, ErrPCName,ErrNotes, ObjectName,ControlName) " & _
            "SELECT " & Err.Number & " AS ErrorNum, " & _
            "'" & Replace(Err.Description, "'", "") & "' AS ErrDesc, " & _
            "#" & Now() & "# AS DateTimeStamp, " & _
            "'" & Environ("username") & "' AS UserName, " & _
            "'" & Environ("computername") & "' AS PCName, " & _
            "'" & strUserNotes & "' As UserNotes, " & _
            "'" & strObjectName & "' as ErrObject, " & _
            "'" & strControlName & "' as ErrControl;"
    
    Debug.Print strSQL
    DoCmd.SetWarnings False
    DoCmd.RunSQL strSQL
    DoCmd.SetWarnings True
    
End Sub

Sub LogErrToText(strUserNotes As String, lngErrNum As Long, strErrDesc As String, Optional strObjectName, Optional strControlName)
On Error GoTo HandleError
Dim fsoSysObj As FileSystemObject
Dim strPath As String
Dim strLogFile As File
Dim txsStream As TextStream
Dim strErrorText As String

'__________________________________________________________________________________________
'Purpose    : To Log any errors that occur to a text file to enable review and determine if the
'             The Error is a USER, PC or SYSTEM error.  As a result take appropriate action
'Created By : {Coders Name Here}
'Created On : {Date the module was written}
'Usage Note : A reference to the 'Microsoft Scripting Runtime' Library is required
'Copyright  : Copyright is retained by {The Author} and this statement must be retained
'             in any use of this module
'Change Log : Last Updated On {Date Here}
'             Last Updated By {Name Here}
'             Reason For Modifications {Details here}
'
'How to Use : When calling this procedure the following are required elements:
'             'User Notes', 'Error Number', 'Error Desc'
'             Optional elements help provide extended data trapping and include:
'             'ObjectName' (the Form/Report name) and 'ControlName' (the field name)
'__________________________________________________________________________________________


    Set fsoSysObj = New FileSystemObject
    
'Define a variable to hold the location of the current log file
    strPath = Application.CurrentProject.Path & "\logs\ErrorLog.txt"

'Now either Open or Create the Text File
'___________________________________________________________________
    On Error Resume Next    'Ignore the Errors that this will create

    Set strLogFile = fsoSysObj.GetFile(strPath) 'Does the file exist?
    If Err <> 0 Then    'If not then create one
        Set strLogFile = fsoSysObj.CreateTextFile(strPath)
    End If
    
'    On Error GoTo 0    'Turn Error Trapping back on again

'Now write the Error Details into the Log file
'___________________________________________________________________

'open text file for reading
    Set txsStream = strLogFile.OpenAsTextStream(ForAppending)
'Write data to file
    With txsStream
        strErrorText = lngErrNum & "|"
        strErrorText = strErrorText & strErrDesc & "|"
        
        strErrorText = strErrorText & Now() & "|"
        strErrorText = strErrorText & Environ("username") & "|"
        strErrorText = strErrorText & Environ("computername") & "|"
        
'Placeholder for User Notes
'         strErrorText = strErrorText & "Notes variable to Go Here " & "|"
        If Len(strUserNotes) > 0 Then
            strErrorText = strErrorText & strUserNotes & "|"
        End If
        
        If Len(strObjectName) > 0 Then
            strErrorText = strErrorText & strObjectName & "|"
        End If
        
        If Len(strControlName) > 0 Then
            strErrorText = strErrorText & strControlName & "|"
        End If
               
        .WriteLine strErrorText
        .Close
    End With

NoError:
    Exit Sub
HandleError:
    'an issue writing to the log file - should the user be told...
    GoTo NoError
End Sub


Function GetScreenShot(strUserNotes As String, lngErrNum As Long, _
    strErrDesc As String, Optional strObjectName, Optional strControlName)
On Error GoTo HandleError
Dim appWord As Word.Application
Dim docWord As Word.Document
Dim rngWord As Word.Range
Dim strErrorText As String

'__________________________________________________________________________________________
'Purpose    : To capture a screen shot of the users system when the error occured
'             This will then be saved to a Word Document for review
'             Most likely this will only be used during testing and not final release
'Created By : {Coders Name Here}
'Created On : {Date the module was written}
'Usage Note : A reference to the 'Microsoft Word' Library is required
'             The Keyboard API MUST be included in the Declarations area, as shown

'           Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
                ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
            
'Copyright  : Copyright is retained by {The Author} and this statement must be retained
'             in any use of this module
'Change Log : Last Updated On {Date Here}
'             Last Updated By {Name Here}
'             Reason For Modifications {Details here}
'
'How to Use : When calling this procedure the following are required elements:
'             'User Notes', 'Error Number', 'Error Desc'
'             Optional elements help provide extended data trapping and include:
'             'ObjectName' (the Form/Report name) and 'ControlName' (the field name)
'__________________________________________________________________________________________

'This will grab the screen shot of entire screen
'    keybd_event vbKeySnapshot, 0, 0, 0
'to get current window
    keybd_event vbKeySnapshot, 1, 0, 0

    DoEvents 'Allows other system events to run..
    
'    On Error Resume Next
    Set appWord = New Word.Application

    With appWord
        .Visible = False
        .ScreenUpdating = False
    End With
    
    Set docWord = appWord.Documents.Add
    Set rngWord = docWord.Range(0)
    rngWord.Paste
    
'Text to insert
        strErrorText = "Err No. :" & lngErrNum & vbCr
        strErrorText = strErrorText & "Err Desc. :" & strErrDesc & vbCr
        strErrorText = strErrorText & "Date.Time :" & Now() & vbCr
        strErrorText = strErrorText & "Username :" & Environ("username") & vbCr
        strErrorText = strErrorText & "PC Name : " & Environ("computername") & vbCr
        
        If Len(strUserNotes) > 0 Then
            strErrorText = strErrorText & "User Notes : " & strUserNotes & vbCr
        End If
        
        If Len(strObjectName) > 0 Then
            strErrorText = strErrorText & "Object Name : " & strObjectName & vbCr
        End If
        
        If Len(strControlName) > 0 Then
            strErrorText = strErrorText & "Control Name: " & strControlName & vbCr
        End If

    With Selection
        .EndKey Unit:=wdStory
        .TypeParagraph
        .TypeText Text:=strErrorText
    End With
    
    With docWord
        TempVars("PathToFile") = Application.CurrentProject.Path & "\logs\ErrImg " & _
                Format(Now(), "dd-mm-yy hh-nn") & ".doc"
        .SaveAs TempVars("PathToFile").Value
        .Close
    End With
    
NoError:
    Set rngWord = Nothing
    Set docWord = Nothing
    appWord.Quit
    Set appWord = Nothing
    Exit Function
HandleError:
    Select Case Err.Number
        Case 13
            'user pressed cancel on inputbox
            strUserNotes = ""
            Resume Next
        Case 462
            'cant open word
        Case Else
            MsgBox "An Error has occured Capturing the Screen Shot...", _
                vbCritical + vbOKOnly, "Screen Capture Error"
    End Select
    GoTo NoError
    
End Function

Function EmailErrDetails()
On Error GoTo HandleError
Dim olApp As Object
Dim olMail As Object
Const olMailItem = 0

'__________________________________________________________________________________________
'Purpose    : To capture a screen shot of the users system when the error occured
'             This will then be saved to a Word Document for review
'             Most likely this will only be used during testing and not final release
'Created By : {Coders Name Here}
'Created On : {Date the module was written}
'Usage Note : A reference to the 'Microsoft Outlook' Library is required for Early Binding
'Copyright  : Copyright is retained by {The Author} and this statement must be retained
'             in any use of this module
'Change Log : Last Updated On {Date Here}
'             Last Updated By {Name Here}
'             Reason For Modifications {Details here}
'
'How to Use : When calling this procedure either use LATE or EARLY Binding
'             EARLY BINDING
'                   Dim olApp As Outlook.Application
'                   Dim olMail As Outlook.MailItem
'                   Set olApp = New Outlook.Application
'                   Set olMail = olApp.CreateItem(olMailItem)
'             LATE BINDING
'                   Set olApp = CreateObject("Outlook.Application")
'                   Set olMail = olApp.CreateItem(olMailItem)
'__________________________________________________________________________________________

    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(olMailItem)
    
    With olMail
        .To = "to@example.com"
        .CC = "cc@example.com"
        .BCC = "bcc@example.com"
        .Subject = "An Error has occured within the database"
        .Body = "ErrDetails To Go Here"
        .Attachments.Add TempVars("PathToFile").Value
        .Display
    End With

NoError:
    Exit Function
HandleError:
    Select Case Err.Number
        Case 438
            'outlook is already open - only instance allowed
            Resume Next
        Case Else
            MsgBox "An error has occured communicating with Outlook.", _
                vbCritical + vbOKOnly, "Email Error"
        End Select
    GoTo NoError
End Function


Function Notify_Email(ErrSource As String, ErrDetails As String, Optional strImagePath As String)
On Error GoTo HandleError
Dim olApp As Object
Dim olMail As Object
Const olMailItem = 0

'To allow for Outlook clients other than 2007 late binding is used
'Dim olApp As Outlook.Application
'Dim olMail As Outlook.MailItem
'    Set olApp = New Outlook.Application
'    Set olMail = olApp.CreateItem(olMailItem)

    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(olMailItem)
    
    With olMail
        .To = "to@example.com"
        .CC = "cc@example.com"
        .BCC = "bcc@example.com"
        .Subject = "An Error has occured within the database"
        .Body = ErrDetails & vbCr & vbCr & "A screen shot has been attached to this email"
        .Attachments.Add (strImagePath)
        .Display
    End With

NoError:
    Exit Function
HandleError:
    MsgBox "An error has occured communicating with Outlook.", vbCritical + vbOKOnly, "Email Error"

End Function
