Public Event ExceptionOccured(ByRef eiExceptionInfo As cExceptionInfo)
 
Private m_blnEnabled As Boolean
 
'*******************************************************************************
'******************                Publics                 *********************
'*******************************************************************************
 
Public Property Let Enabled(ByVal blnNewEnabled As Boolean)
  If blnNewEnabled Then
    Call modException.StartExceptionHandler
  Else
    Call modException.StopExceptionHandler
  End If
  m_blnEnabled = blnNewEnabled
End Property
 
Public Property Get Enabled() As Boolean
  Enabled = m_blnEnabled
End Property
 
Public Sub OnExceptionOccured(ByRef eiExceptionInfo As cExceptionInfo)
  RaiseEvent ExceptionOccured(eiExceptionInfo)
End Sub
 
 
'*******************************************************************************
'******************                Privates                *********************
'*******************************************************************************
 
Private Sub Class_Initialize()
  m_blnEnabled = False
  Set modException.g_eh = Me
End Sub

Public Code As Long
Public Continuable As Boolean
Public Address As Long

' Special adaption of CopyMemory
Private Declare Sub CopyExceptionRecord Lib "kernel32.dll" Alias _
  "RtlMoveMemory" (ByRef Destination As EXCEPTION_RECORD, ByVal Source As Long, _
  ByVal Length As Long)
 
' Sets calback for exception handler
Private Declare Function SetUnhandledExceptionFilter Lib "kernel32.dll" (ByVal _
  lpTopLevelExceptionFilter As Long) As Long
 
' return value of exception handler
Private Const c_EXCEPTION_CONTINUE_EXECUTION As Long = -1&
Private Const c_EXCEPTION_CONTINUE_SEARCH As Long = 0&
Private Const c_EXCEPTION_EXECUTE_HANDLER As Long = 1&
 
Private Const c_EXCEPTION_NONCONTINUABLE As Long = &H1&
Private Const c_EXCEPTION_CONTINUABLE As Long = &H0&  ' Nicht im Windows-API 
' als Konstante definiert.
 
' Number of elements of field Information ins EXCEPTION_RECORD-structure.
Private Const c_EXCEPTION_MAXIMUM_PARAMETERS As Long = 15&
 
' Datastructure with info about exception
Private Type EXCEPTION_RECORD
  ExceptionCode As Long
  ExceptionFlags As Long
  pExceptionRecord As Long    ' Pointer to previsous EXCEPTION_RECORD.
  ExceptionAddress As Long
  NumberParameters As Long
  Information(0 To c_EXCEPTION_MAXIMUM_PARAMETERS - 1) As Long
End Type
 
' Processor specific structure with exception info. Not relevant.
Private Type CONTEXT
  DummyMember As Long
End Type
 
Private Type EXCEPTION_POINTERS
  ExceptionRecord As EXCEPTION_RECORD
  ContextRecord As CONTEXT
End Type
 
Private Declare Function SetErrorMode Lib "kernel32.dll" (ByVal wMode As Long) _
  As Long
 
Private Const c_SEM_FAILCRITICALERRORS As Long = &H1&
Private Const c_SEM_NOGPFAULTERRORBOX As Long = &H2&
Private Const c_SEM_NOALIGNMENTFAULTEXCEPT As Long = &H4&
Private Const c_SEM_NOOPENFILEERRORBOX As Long = &H8000&
 
' Function Pointer to Windows error handler
Private m_lpOldExceptionProc As Long
 
Public g_eh As cExceptionHandler
 
Public Sub StartExceptionHandler()
 
  'It's not clear, if this call is necessary for Windows XP
  Call SetErrorMode(c_SEM_NOGPFAULTERRORBOX)
  m_lpOldExceptionProc = SetUnhandledExceptionFilter(AddressOf ExceptionHandler)
End Sub
 
Public Sub StopExceptionHandler()
  Call SetUnhandledExceptionFilter(c_EXCEPTION_EXECUTE_HANDLER)
  m_lpOldExceptionProc = 0
End Sub
 
Public Function ExceptionHandler( _
  ByRef lpException As EXCEPTION_POINTERS) As Long
 
  ' Continue on exception.
  ExceptionHandler = c_EXCEPTION_CONTINUE_EXECUTION
 
  ' Tell the App that an exception occured and path exception information.
  ' lpException.ExceptionRecord <> 0 means, that there is a chain of nested
  ' exceptions. Follow back pointer to root exception.
  Dim er As EXCEPTION_RECORD
 
  ' Get current exception record.
  er = lpException.ExceptionRecord
 
  ' Follow back to root exception
  Do Until er.pExceptionRecord = 0
    Call CopyExceptionRecord(er, er.pExceptionRecord, LenB(er))
  Loop
 
  ' Fill exception Info
  Dim ei As New cExceptionInfo
  With ei
    .Address = er.ExceptionAddress
    .Code = er.ExceptionCode
    .Continuable = (er.ExceptionFlags = c_EXCEPTION_CONTINUABLE)
  End With
  Call g_eh.OnExceptionOccured(ei)
End Function

Gruß
Dirk

--
?Get it right the first time