clserrorhandle.cls

VB automaticlly grap error event

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

Public Property Get ErrorCode() As String
    'This is the error code that the rest of the addin can see from the file or the reg
    ErrorCode = strErrorCode
End Property

Public Sub InsertCode()
    'This function is the one that does all the work. It is the function that adds
    'The code to the procedure
Dim oCodePane As CodePane
Dim oCodeMod As CodeModule
Dim lngStartLine As Long
Dim lngStartCol As Long
Dim lngEndLine As Long
Dim lngEndCol As Long
Dim strProcName As String
Dim FindIt As Boolean
Dim eProcKind As vbext_ProcKind
Dim ExitStatement As String
 
    'make sure the class has the lastes error cose
    GetErrorCode
    
    Set oCodePane = VBInstance.ActiveCodePane
    
    If oCodePane Is Nothing Then
        Exit Sub
    End If
    
    Set oCodeMod = oCodePane.CodeModule
    
    'Get the postions of the Procedure
    oCodePane.GetSelection lngStartLine, lngStartCol, lngEndLine, lngEndCol
    
    'Now get the name of procedure
    strProcName = oCodeMod.ProcOfLine(lngStartLine, eProcKind)
    
    If strProcName = "" Then
        'If the name is nothing then we must be at the start so to add a little more
        'Error handling to the code, I'll make sure that Option explicit is added
        lngEndLine = oCodeMod.CountOfLines
        FindIt = oCodeMod.Find("Option Explicit", 1, 1, lngEndLine, -1, True, False, False)
        
        If FindIt = False Then
            'Insert Option Explicit
            oCodeMod.InsertLines 1, "Option Explicit"
        End If
    Else
       'If the name is not nothing then we must be in a procedure, so get the details
        lngStartLine = oCodeMod.ProcStartLine(strProcName, eProcKind)
        lngEndLine = oCodeMod.ProcCountLines(strProcName, eProcKind) + lngStartLine
        
        'Now we know the dimensions of the Proc search it for any current error handling
        FindIt = oCodeMod.Find("On Error Goto " & strProcName & "Error", lngStartLine, 1, lngEndLine, -1, True, False, False)
        
        'If the error code is already there then exit the function
        If FindIt = False Then
            lngStartLine = oCodeMod.ProcBodyLine(strProcName, eProcKind)
            lngStartLine = lngStartLine + 1
            
            Do While InStr(1, oCodeMod.Lines(lngStartLine, 1), "Dim", vbTextCompare) > 0
                lngStartLine = lngStartLine + 1
            Loop
            
            oCodeMod.InsertLines lngStartLine, "On Error Goto " & strProcName & "Error" & vbCrLf
        End If
        
        'Now I check to make sure that the code to handle the error isn't already there
        lngStartLine = oCodeMod.ProcStartLine(strProcName, eProcKind)
        lngEndLine = oCodeMod.ProcCountLines(strProcName, eProcKind) + lngStartLine
        
        FindIt = oCodeMod.Find(strProcName & "Error:", lngStartLine, 1, lngEndLine, -1, True, False, False)
        
        'If it does then we exit the function and dont add anymore
        If FindIt = False Then
            If eProcKind = vbext_pk_Proc Then
                'method or function
                FindIt = oCodeMod.Find("Function ", lngStartLine, 1, lngEndLine, -1, False, False, False)
                
                If FindIt = True Then
                    ExitStatement = vbTab & "Exit Function"
                Else
                    ExitStatement = vbTab & "Exit Sub"
                End If
            Else
                ExitStatement = vbTab & "Exit Property"
            End If
            
            'Find the last statement
            lngStartLine = oCodeMod.ProcStartLine(strProcName, eProcKind)
            lngStartLine = lngStartLine + oCodeMod.ProcCountLines(strProcName, eProcKind)
            
            Do While StrComp(oCodeMod.Lines(lngStartLine, 1), "", vbTextCompare) = 0
                lngStartLine = lngStartLine - 1
            Loop
            
            'Insert the line
            If ProcNamePos = 0 Then
                oCodeMod.InsertLines lngStartLine, vbCrLf & ExitStatement & vbCrLf & strProcName & "Error:" & vbCrLf & vbTab & strErrorCode
            Else
                oCodeMod.InsertLines lngStartLine, vbCrLf & ExitStatement & vbCrLf & strProcName & "Error:" & vbCrLf & vbTab & Left$(strErrorCode, ProcNamePos - 2) & "," & Chr$(34) & strProcName & Chr$(34) & Right$(strErrorCode, Len(strErrorCode) - ProcNamePos - 7)
            End If
        End If
    End If
End Sub

Public Sub GetErrorCode()
Dim strFileName As String
Dim intFileNumber As Integer

    If VBInstance.ActiveVBProject.FileName <> "" Then
        strFileName = Left$(VBInstance.ActiveVBProject.FileName, Len(VBInstance.ActiveVBProject.FileName) - 3) & ".ERC"
        intFileNumber = FreeFile
        
        If FileExists(strFileName) Then
            Open strFileName For Input As intFileNumber
                Input #intFileNumber, strErrorCode
            Close #intFileNumber
        End If
        
        If strErrorCode = "" Then
            strErrorCode = GetSetting("AutoErrorHandler", "Settings", "ErrorCode")
        End If
    End If
End Sub

Public Sub SaveErrorCode(StrMyErrorCode As String)
Dim strFileName As String
Dim intFileNumber As Integer

    If VBInstance.ActiveVBProject.FileName <> "" Then
        strErrorCode = StrMyErrorCode
        SaveSetting "AutoErrorHandler", "Settings", "ErrorCode", strErrorCode
    
        strFileName = Left$(VBInstance.ActiveVBProject.FileName, Len(VBInstance.ActiveVBProject.FileName) - 3) & ".ERC"
        intFileNumber = FreeFile
        
        Open strFileName For Output As intFileNumber
            Write #intFileNumber, strErrorCode
        Close #intFileNumber
    End If
    
End Sub

Private Sub Class_Terminate()
    Call SaveErrorCode(strErrorCode)
End Sub

Private Function ProcNamePos() As Integer
On Error Resume Next
    ProcNamePos = InStr(1, strErrorCode, "ProcName", vbTextCompare)
End Function