GStacker.bas #1

Attribute VB_Name = "GStacker"
Option Explicit

Private Type ProcType
    ModuleName As String
    ProcName As String
End Type

Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
        (ByVal hwnd As Long, ByVal lpOperation As String, _
        ByVal lpFile As String, ByVal lpParameters As String, _
        ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private g_err As ErrObject

' Set the following to True to display an error dialog in the event of an error
Private Const ERR_DISPLAY_ERROR = True

' Set the following the path and name of the file to log errors to
Private m_ErrorLogFile As String

' The name of the application from which we are being called.
Private m_AppName As String
Private m_AppVersion As String

Private m_StackTrace As New Collection
Private m_ErrNum As Long
Private m_ErrMsg As String
Private m_ClientErrObj As ErrObject

Private m_Tracing As Boolean

Private g_StackTrace As StackTrace

Public Declare Sub OutputDebugStringA Lib "kernel32" (ByVal pMsg As String)

Public Property Let Tracing(OnOff As Boolean)
    m_Tracing = OnOff
End Property

Public Property Get Tracing() As Boolean
    Tracing = m_Tracing
End Property

Public Property Get err() As ErrObject

    If g_err Is Nothing Then
        Set g_err = New ErrObject
    End If
    Set err = g_err
    
End Property

' This next is not needed if error handling is implemented in a seperate DLL
Public Property Get GStackTrace() As StackTrace

    If g_StackTrace Is Nothing Then
        Set g_StackTrace = New StackTrace
        g_StackTrace.Initialize err
    End If
    Set GStackTrace = g_StackTrace
    
End Property

Public Sub SetApplicationName(AppName As String, Version As String)
    m_AppName = AppName
    m_AppVersion = Version
End Sub

Public Property Set ClientErrObject( _
            ByVal ErrorObject As ErrObject)
    Set m_ClientErrObj = ErrorObject
End Property

Public Property Get ClientErrObject() As ErrObject
    Set ClientErrObject = m_ClientErrObj
End Property


Public Sub Leave(ModuleName As String, _
                 ProcName As String)
    
    If Tracing Then
        Dim Msg As String
        Msg = "Leave: " & ModuleName & "." & ProcName & SysResourcesGetWorkingSet
        If m_ClientErrObj.Number <> 0 Then
            Msg = Msg & " - err - " & m_ClientErrObj.Number & _
                    m_ClientErrObj.Description
        End If
        TraceMsg Msg
    End If

    If m_ClientErrObj.Number <> 0 Then
        ' We are exiting up the stack and an error has happened
        ' Save error if we are at the point of error (first in stack)
        If m_StackTrace.Count = 0 Then
            SaveError m_ClientErrObj
        End If
        AddToStack ModuleName, ProcName
    End If

End Sub

Public Sub AddToStack(ByVal ModuleName As String, _
                 ByVal ProcName As String)
    Dim NewTrace As Collection
    Set NewTrace = New Collection
    NewTrace.Add ModuleName, "Module"
    NewTrace.Add ProcName, "Proc"
    m_StackTrace.Add NewTrace
End Sub

Public Sub Report(ByVal ModuleName As String, _
                 ByVal ProcName As String)
    Dim Text As String
    Dim ThisProc As Integer
    Dim FullErrorMsg As String
    Dim Msg As String

    ' Save if at top of stack - may not have executed "Leave" above
    If m_StackTrace.Count = 0 Then
        SaveError m_ClientErrObj
    End If

    ' Since we don't know what state we are in, disable error trapping
    On Error Resume Next

    m_ErrorLogFile = VB.App.path & "\error.log"
    
    ' If reporting error then want to include top of stack if set
    If Len(ProcName) <> 0 Then
        AddToStack ModuleName, ProcName
    End If
    
    ' Log the error
    FullErrorMsg = FormatError(m_ErrMsg, m_ErrNum)
    LogErrorToFile FullErrorMsg, m_ErrorLogFile
    
    If ERR_DISPLAY_ERROR Then
        Beep
        Msg = "The following error has occurred in procedure: " & vbCrLf
        Msg = Msg & ReportModuleName() & vbCrLf & vbCrLf
        Msg = Msg & "Error (" & m_ErrNum & ") " & m_ErrMsg & vbCrLf & vbCrLf
        Msg = Msg & "The error has been logged in: " & m_ErrorLogFile & vbCrLf & vbCrLf
        Msg = Msg & "Please report to support together with notes about what you were doing when it happened!"

        MsgBox Msg, vbCritical, "P4OFC Error"
    End If

End Sub

Private Function ReportModuleName() As String
    If m_StackTrace.Count = 0 Then
        ReportModuleName = "Unknown.Unknown"
    Else
        ReportModuleName = m_StackTrace(1)!Module & "." & m_StackTrace(1)!Proc
    End If
End Function

Public Sub Clear()
    Set m_StackTrace = New Collection
End Sub

Private Sub SaveError(ByVal oErr As ErrObject)
    m_ErrNum = oErr.Number
    m_ErrMsg = oErr.Description
End Sub

Private Sub LogErrorToFile(FullErrorMsg As String, strFile As String)

    ' Comments  : Logs the most recent error to a file
    ' Parameters: strError - error string
    '             lngError - error number
    '             intErl - error line number
    '             strFile - name of the file to log the errors to
    '             fExpandedStats - True to include additional system information, False otherwise
    ' Returns   : nothing
    '
    Dim intFile As Integer

    On Error Resume Next
    intFile = FreeFile
    Open strFile For Append As intFile

    Print #intFile, FullErrorMsg

    ' Close the objects
    Close #intFile

End Sub

Private Function FormatError(strError As String, lngError As Long) As String
    Dim Msg As String
    Dim Temp As String
    Dim ThisProc As Integer
    
    On Error Resume Next
    Msg = "=============================================" & vbCrLf
    Msg = Msg & "P4-" & m_AppName & " Application Error Information" & vbCrLf
    Msg = Msg & "=============================================" & vbCrLf
    Msg = Msg & "Current Time   : " & Now & vbCrLf
    Msg = Msg & "Version        : " & DLLVersion() & vbCrLf
    Msg = Msg & "p4com.dll ver  : " & COMDLLVersion() & vbCrLf
    Msg = Msg & "App Version    : " & m_AppVersion & vbCrLf
    Msg = Msg & "Win Version    : " & WindowsVersion() & vbCrLf
    Msg = Msg & "Error String   : " & Left$(strError, 255) & vbCrLf
    Msg = Msg & "Error Number   : " & CStr(lngError) & vbCrLf
    Msg = Msg & "Error Procedure: " & ReportModuleName() & vbCrLf
    Msg = Msg & vbCrLf
    Msg = Msg & "Procedure Stack" & vbCrLf
    Msg = Msg & "---------------" & vbCrLf

    For ThisProc = 1 To m_StackTrace.Count
        Temp = Temp & Format(ThisProc, "00") & Space$(ThisProc * 2) & _
            m_StackTrace(ThisProc)!Module & "." & _
            m_StackTrace(ThisProc)!Proc & vbCrLf
    Next
    Msg = Msg & Temp
    FormatError = Msg
    
End Function

Public Sub TraceMsg(Msg As String)
    OutputDebugStringA Msg
End Sub

Private Sub CreateEmail(BodyText As String)
    ' Create an email and ask them to send it.
    Dim Msg As String
    Dim Result As Long
    Dim EmailAddress As String
    
    On Error Resume Next
    EmailAddress = RegOptions.SupportEmailAddress
    Msg = "mailto:" & EmailAddress & _
        "?subject=P4OFC%20Error&body=" & URLEncode(BodyText)
    Result = ShellExecute(0, "Open", Msg, _
                    vbNullString, App.path, vbNormalFocus)
    
End Sub

Public Function URLEncode(ByVal Text As String) As String
    Dim i As Integer
    Dim acode As Integer
    Dim char As String
    
    URLEncode = Text
    
    For i = Len(URLEncode) To 1 Step -1
        acode = Asc(Mid$(URLEncode, i, 1))
        Select Case acode
            Case 48 To 57, 65 To 90, 97 To 122
                ' don't touch alphanumeric chars
            Case 32
                ' replace space with
                URLEncode = Left$(URLEncode, i - 1) & "%20" & Mid$(URLEncode, i + 1)
            Case 10
                ' Handle for Linefeed for MS products
                URLEncode = Left$(URLEncode, i - 1) & "%0d" & Mid$(URLEncode, i + 1)
            Case Else
                ' don't touch - seems alright
'                URLEncode = Left$(URLEncode, i - 1) & "%" & Hex$(acode) & Mid$ _
'                    (URLEncode, i + 1)
        End Select
    Next
    
End Function