VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "errHandler"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

'
' error types
Enum errType
    errItem = 0
    errColl = 1
End Enum

'
' return/option values
Enum errReturn
    errExit = 0
    errResume = 1
    errNext = 2
    errselect = 3
End Enum

'
' handler storage
Private errDefRtn As errReturn
Private errDefType As errType
'
' logging storage
Private errLogFileName As String
Private errLogFlag As Boolean

Public Function errHandler(objErrColl As Variant, Optional intType As errType, Optional errOption As errReturn, Optional errRefName As String) As errReturn
Attribute errHandler.VB_Description = "Provides expanded error handling"
    
    ' -------------------------------------------------------------------------------------------
    ' produce msg and prompt for response
    '
    ' inputs:
    '   objErrColl  - DAO collection -OR- VBA Err object
    '   intType     - errType enum that describes objErrColl (coll or item)
    '   errOption   - errReturn enum sets dialog behavior (exit, resume, next, select)
    '   errRefName  - string to reference caller
    '
    ' returns:
    '   errExit     - end program
    '   errResume   - try again
    '   errNext     - skip to next line
    ' ------------------------------------------------------------------------------------

    '
    Dim strMsg As String
    Dim strTitle As String
    Dim rtnValue As errReturn
    '
    ' retrieve action option
    If IsMissing(errOption) Then
        errOption = errDefRtn
    End If
    '
    ' retrieve reference name
    If IsMissing(errRefName) Then
        errRefName = ""
    Else
        errRefName = " from " & errRefName
    End If
    '
    ' build full message
    strMsg = errMsg(objErrColl, intType)
    '
    ' write it out, if allowed
    If errLogFlag = True Then
        LogError strMsg
    End If
    '
    ' evaluate things
    Select Case errOption
        Case errExit
            udtErrDialog.Title = "Exiting Program"
            udtErrDialog.Message = strMsg
            udtErrDialog.Buttons = Array("&Exit")
            frmErrDialog.Show vbModal
            rtnValue = errExit
            '
        Case errResume, errNext
            udtErrDialog.Title = "Error Message" & errRefName
            udtErrDialog.Message = strMsg
            udtErrDialog.Buttons = Array("&OK")
            frmErrDialog.Show vbModal
            rtnValue = errOption
            '
        Case Else
            udtErrDialog.Title = "Error Message" & errRefName
            udtErrDialog.Message = strMsg
            udtErrDialog.Buttons = Array("&Cancel", "&Retry", "&Ignore")
            frmErrDialog.Show vbModal
            rtnValue = udtErrDialog.Return
    End Select
    '
    ' give it back
    errHandler = rtnValue
    '
End Function

Public Property Get DefaultAction() As errReturn
Attribute DefaultAction.VB_Description = "Sets the default action of handler"
    '
    ' return default
    '
    DefaultAction = errDefRtn
    '
End Property

Public Property Let DefaultAction(ByVal vNewValue As errReturn)
    '
    ' verify parm and store
    '
    If vNewValue >= errExit Or vNewValue <= errselect Then
        errDefRtn = vNewValue
    End If
    '
End Property
    
Public Function errMsg(objErrColl As Variant, intType As errType) As String
Attribute errMsg.VB_Description = "Returns full error message"
    '
    ' build and return complete error msg
    '
    Dim strMsg As String
    Dim objItem As Error
    '
    strMsg = ""
    '
    If intType = errColl Then
        For Each objItem In objErrColl
            strMsg = strMsg & "<" & CStr(objItem.Number) & "> "
            strMsg = strMsg & objItem.Description
            strMsg = strMsg & " (in " & objItem.Source & ")." & vbCrLf
        Next
    Else ' intType= errItem
        strMsg = "<" & objErrColl.Number & "> "
        strMsg = strMsg & objErrColl.Description
        strMsg = strMsg & " (in " & objErrColl.Source & ")"
        '
        udtErrDialog.HelpFile = objErrColl.HelpFile
        udtErrDialog.HelpID = objErrColl.HelpContext
    End If
    '
    errMsg = strMsg
    '
End Function

Public Property Get DefaultType() As errType
Attribute DefaultType.VB_Description = "Sets the assumed error Type (ErrItem or ErrColl)."
    '
    DefaultType = errDefType
    '
End Property

Public Property Let DefaultType(ByVal vNewValue As errType)
    '
    If vNewValue >= errColl Or vNewValue <= errItem Then
        errDefType = vNewValue
    End If
    '
End Property

Private Sub Class_Initialize()
    '
    ' set starting values
    errDefRtn = errExit
    errDefType = errItem
    '
    errLogFileName = App.EXEName & ".err"
    errLogFlag = False
    '
    udtErrDialog.Buttons = ""
    udtErrDialog.HelpFile = ""
    udtErrDialog.HelpID = -1
    udtErrDialog.Message = ""
    udtErrDialog.Return = -1
    udtErrDialog.Title = ""
    '
End Sub

Private Sub LogError(strErrMsg As String)
Attribute LogError.VB_Description = "Toggles error logging On/Off (True/False)."
    '
    ' write error to disk file
    On Error GoTo LocalErr
    '
    Dim intChFile As Integer
    '
    intChFile = FreeFile
    Open errLogFileName For Append As intChFile
        Print #intChFile, Format(Now, "general date")
        Print #intChFile, strErrMsg
        Print #intChFile, ""
    Close intChFile
    '
    Exit Sub
    '
LocalErr:
    ' trouble with file stuff!
    Err.Raise vbObjectError + 1, "errHandler.LogError", "Can't write log file [" & errLogFileName & "]"
    '
End Sub

Public Property Get LogFileName() As String
Attribute LogFileName.VB_Description = "target of error logging."
    '
    LogFileName = errLogFileName
    '
End Property

Public Property Let LogFileName(ByVal vNewValue As String)
    '
    errLogFileName = vNewValue
    '
End Property

Public Property Get WriteLogFlag() As Boolean
Attribute WriteLogFlag.VB_Description = "Toggles error logging On/Off (True/False)."
    '
    WriteLogFlag = errLogFlag
    '
End Property

Public Property Let WriteLogFlag(ByVal vNewValue As Boolean)
    '
    errLogFlag = vNewValue
    '
End Property

