vb6集成环境on error错误处理代码添加插件

插件下载地址（请下载最新版v1.0.5）：

http://code.google.com/p/vsaddin/downloads

 

安装方法：
1.点击菜单“工程-引用”，选择这个dll
2.然后点击菜单“外接程序-外接程序管理器”，选择“Insert Error Hand”，把右下角两个框框都勾起来
3.这样你的菜单“外接程序”中就会多出“Insert Error Hand”这一项

使用方法：
将要处理的代码编辑窗口打开，然后点击菜单“外接程序-Insert Error Hand”

ps：插件会只会处理已经打开的代码编辑窗口

 

主要代码如下：

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '描述：VB6 IDE 函数过程错误处理代码添加 '作者：sysdzw '邮箱：sysdzw@163.com QQ：171977759 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '修改历史(有对代码修改的请在下面增加记录并且发送至邮箱sysdzw@163.com) '-------------------------------------------------------------------------- '日期 修改者 版本 说明 '----------------------------------------------------------------------------- '2010-12-1 sysdzw v1.0.1 初版 '2010-12-2 sysdzw v1.0.2 改进了如果过程中用户已经做了错误处理就不再处理 ' v1.0.3 增加了对Property过程的支持 '2010-12-3 sysdzw v1.0.4 修正了在过程的声明参数为多行情况下时处理发生错误 ' v1.0.5 增加了对代码窗口监视，使得代码一发生变动即处理 '----------------------------------------------------------------------------- Option Explicit Public FormDisplayed As Boolean Public VBInstance As VBIDE.VBE Dim mcbMenuCommandBar As Office.CommandBarControl Public WithEvents MenuHandler As CommandBarEvents 'command bar event handler 'strMethodName 方法名 'strType 类型，为Sub或Function 'ojbCodeModel 代码窗口，用于检索方法的行号行数 Private Sub dealMethod(ByVal strMethodName$, ByVal strType$, ojbCodeModel As CodeModule) On Error GoTo ErrHand Dim lngFirstProcLine&, lngFirstBodyLine&, lngProcLinesCount& Dim lngCurrentLine& lngFirstProcLine = ojbCodeModel.ProcStartLine(strMethodName, vbext_pk_Proc) '整个过程的第一行，比如过程前的注释的地方，适用于添加函数注释 lngFirstBodyLine = ojbCodeModel.ProcBodyLine(strMethodName, vbext_pk_Proc) '过程代码的第一行，一般就是过程的声明 lngProcLinesCount = ojbCodeModel.ProcCountLines(strMethodName, vbext_pk_Proc) '过程的代码数 '如果整个过程中没有"On Error GoTo/Resume xxx"语句则在声明的下一行添加"On Error GoTo ErrHand"，如果用户自己处理了那么则退出 If Not isMatchReg(ojbCodeModel.Lines(lngFirstProcLine, lngProcLinesCount), "^ *?On Error (?:GoTo|Resume) *?'?") Then lngCurrentLine = lngFirstBodyLine Do If Right(ojbCodeModel.Lines(lngCurrentLine, 1), 1) <> "_" Then '由于有些声明是分多行写的，所以要找到最右边不是“_”的行号 ojbCodeModel.InsertLines lngCurrentLine + 1, vbTab & "On Error GoTo ErrHand" & vbCrLf lngProcLinesCount = lngProcLinesCount + 2 Exit Do End If lngCurrentLine = lngCurrentLine + 1 Loop '如果没有"ErrHand:"则在"End Sub/Funtion"前一行添加"ErrHand:"等 If Not isMatchReg(ojbCodeModel.Lines(lngFirstProcLine, lngProcLinesCount), "^^ *?ErrHand: *?'?.*?") Then '查找"End Sub/Funtion"所在的行 lngCurrentLine = lngFirstProcLine + lngProcLinesCount - 1 Do If isMatchReg(ojbCodeModel.Lines(lngCurrentLine, 1), "^ *?End " & strType & " *?'?") Then '找到了"End Sub/Funtion"所在的行，开始在前面添加"ErrHand:"等 ojbCodeModel.InsertLines lngCurrentLine, vbCrLf & vbTab & "Exit " & strType & vbCrLf & _ "ErrHand:" & vbCrLf & _ vbTab & "MsgBox ""Error Number: "" & vbTab & Err.Number & vbCrLf & ""Error Description: "" & vbTab & Err.Description & vbCrLf & ""Error " & strType & ": "" & vbTab & """ & strMethodName & """, vbExclamation" Exit Do End If lngCurrentLine = lngCurrentLine - 1 Loop End If End If Exit Sub ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "dealMethod" & vbCrLf & _ "Arguments: " & vbTab & "strMethodName = " & strMethodName & "; strType = " & strType, vbExclamation End Sub 'strPropertyName 属性名 'strType 类型，为Property Set/Let/Get 'ojbCodeModel 代码窗口，用于检索方法的行号行数 Private Sub dealProperty(ByVal strPropertyName$, ByVal strType$, ojbCodeModel As CodeModule) On Error GoTo ErrHand Dim strData$, lngCurrentLine& Dim lngPropertyFirstLine&, strPropertyCode$ strData = ojbCodeModel.Lines(1, ojbCodeModel.CountOfLines) lngPropertyFirstLine = regGetStr1Line(strData, "^(?:public|private)? *?" & strType & " " & strPropertyName & "/(?") strPropertyCode = regGetStr1(strData, "^(?:public|private)? *?" & strType & " " & strPropertyName & "[/s/S]+?^ *?End Property *?'?") '如果整个过程中没有"On Error GoTo/Resume xxx"语句则在声明的下一行添加"On Error GoTo ErrHand"，如果用户自己处理了那么则退出 If Not isMatchReg(strPropertyCode, "^ *?On Error (?:GoTo|Resume) *?'?") Then lngCurrentLine = lngPropertyFirstLine Do If Right(ojbCodeModel.Lines(lngCurrentLine, 1), 1) <> "_" Then '由于有些声明是分多行写的，所以要找到最右边不是“_”的行号 ojbCodeModel.InsertLines lngCurrentLine + 1, vbTab & "On Error GoTo ErrHand" & vbCrLf Exit Do End If lngCurrentLine = lngCurrentLine + 1 Loop '如果没有"ErrHand:"则在"End Property"前一行添加"ErrHand:"等 If Not isMatchReg(strPropertyCode, "^^ *?ErrHand: *?'?.*?") Then '查找"End Property"所在的行 lngCurrentLine = lngPropertyFirstLine + 3 Do If isMatchReg(ojbCodeModel.Lines(lngCurrentLine, 1), "^ *?End Property *?'?") Then '找到了"End Property"所在的行，开始在前面添加"ErrHand:"等 ojbCodeModel.InsertLines lngCurrentLine, vbCrLf & vbTab & "Exit Property" & vbCrLf & _ "ErrHand:" & vbCrLf & _ vbTab & "MsgBox ""Error Number: "" & vbTab & Err.Number & vbCrLf & ""Error Description: "" & vbTab & Err.Description & vbCrLf & ""Error Property: "" & vbTab & """ & Right(strType, 3) & " " & strPropertyName & """, vbExclamation" Exit Do End If lngCurrentLine = lngCurrentLine + 1 Loop End If End If Exit Sub ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "dealProperty" & vbCrLf & _ "Arguments: " & vbTab & "strPropertyName = " & strPropertyName & "; strType = " & strType, vbExclamation End Sub Private Sub AddinInstance_OnBeginShutdown(custom() As Variant) On Error GoTo ErrHand frmWatch.tmrWatch.Enabled = False Unload frmWatch Exit Sub ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "AddinInstance_OnBeginShutdown", vbExclamation End Sub 'this event fires when the menu is clicked in the IDE Private Sub MenuHandler_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean) On Error GoTo ErrHand Dim objCodePane As CodePane ' frmWatch.Show 1 frmWatch.tmrWatch.Enabled = False For Each objCodePane In VBInstance.CodePanes dealCodeModule objCodePane.CodeModule Next frmWatch.tmrWatch.Enabled = True Exit Sub ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "MenuHandler_Click", vbExclamation End Sub Public Sub dealCodeModule(ByVal ojbCodeModule As CodeModule) On Error GoTo ErrHand ' On Error GoTo ErrHand Dim strData$, strDataNew$ Dim reg As Object Dim matchs As Object, match As Object Dim lngPropertyFirstLine&, strPropertyCode$ Set reg = CreateObject("vbscript.regexp") reg.Global = True reg.IgnoreCase = True reg.MultiLine = True reg.Pattern = "^(?:public|private)? *?(sub|function|Property (?:Let|Set|Get)) +?(/w+)/(?" '有代码时再处理 If ojbCodeModule.CountOfLines > 0 Then strData = ojbCodeModule.Lines(1, ojbCodeModule.CountOfLines) Set matchs = reg.Execute(strData) For Each match In matchs If InStr(match.SubMatches(0), "Property") > 0 Then 'dealProperty类型 dealProperty match.SubMatches(1), match.SubMatches(0), ojbCodeModule ', lngPropertyFirstLine, strPropertyCode Else 'Sub 或 Function dealMethod match.SubMatches(1), match.SubMatches(0), ojbCodeModule End If Next End If Exit Sub ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "dealCodeModule", vbExclamation End Sub '------------------------------------------------------ 'this method adds the Add-In to VB '------------------------------------------------------ Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant) On Error GoTo ErrHand 'save the vb instance Set VBInstance = Application 'this is a good place to set a breakpoint and 'test various addin objects, properties and methods If ConnectMode = ext_cm_External Then 'Used by the wizard toolbar to start this wizard Else Set mcbMenuCommandBar = AddToAddInCommandBar("Insert Error Hand") 'sink the event Set Me.MenuHandler = VBInstance.Events.CommandBarEvents(mcbMenuCommandBar) End If If ConnectMode = ext_cm_AfterStartup Then If GetSetting(App.Title, "Settings", "DisplayOnConnect", "0") = "1" Then 'set this to display the form on connect End If End If Set frmWatch.VBInstance = VBInstance Set frmWatch.Connect = Me Load frmWatch frmWatch.tmrWatch.Enabled = True ' MsgBox VBInstance.CodePanes.Count Exit Sub ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "AddinInstance_OnConnection", vbExclamation End Sub '------------------------------------------------------ 'this method removes the Add-In from VB '------------------------------------------------------ Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant) On Error GoTo ErrHand 'delete the command bar entry mcbMenuCommandBar.Delete 'shut down the Add-In If FormDisplayed Then SaveSetting App.Title, "Settings", "DisplayOnConnect", "1" FormDisplayed = False Else SaveSetting App.Title, "Settings", "DisplayOnConnect", "0" End If Exit Sub ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "AddinInstance_OnDisconnection", vbExclamation End Sub Function AddToAddInCommandBar(sCaption As String) As Office.CommandBarControl On Error GoTo ErrHand Dim cbMenuCommandBar As Office.CommandBarControl 'command bar object Dim cbMenu As Object 'see if we can find the Add-Ins menu Set cbMenu = VBInstance.CommandBars("Add-Ins") If cbMenu Is Nothing Then 'not available so we fail Exit Function End If 'add it to the command bar Set cbMenuCommandBar = cbMenu.Controls.Add(1) 'set the caption cbMenuCommandBar.Caption = sCaption Set AddToAddInCommandBar = cbMenuCommandBar Exit Function ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "AddToAddInCommandBar", vbExclamation End Function '测试正则是否匹配 Private Function isMatchReg(strData$, strPattern$) As Boolean On Error GoTo ErrHand Dim reg As Object Set reg = CreateObject("vbscript.regexp") reg.Global = True reg.IgnoreCase = True reg.MultiLine = True reg.Pattern = strPattern isMatchReg = reg.test(strData) Exit Function ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "isMatchReg", vbExclamation End Function '得到正则括号的第一个匹配项 Private Function regGetStr1(strData$, strPattern$) As String On Error GoTo ErrHand Dim reg As Object Dim matchs As Object, match As Object Set reg = CreateObject("vbscript.regexp") reg.Global = False reg.IgnoreCase = True reg.MultiLine = True reg.Pattern = strPattern Set matchs = reg.Execute(strData$) If matchs.Count >= 1 Then regGetStr1 = matchs(0) End If Exit Function ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "regGetStr1", vbExclamation End Function '得到正则括号的第一个匹配项所在的行 Private Function regGetStr1Line(ByVal strData$, strPattern$) As Long On Error GoTo ErrHand Dim reg As Object Dim matchs As Object, match As Object Set reg = CreateObject("vbscript.regexp") reg.Global = False reg.IgnoreCase = True reg.MultiLine = True reg.Pattern = strPattern Set matchs = reg.Execute(strData$) If matchs.Count >= 1 Then regGetStr1Line = UBound(Split(Left(strData, matchs(0).FirstIndex + 1), vbCrLf)) + 1 End If Exit Function ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "regGetStr1Line", vbExclamation End Function '得到正则的数组 Private Function regResult(strData$, strPattern$) On Error GoTo ErrHand Dim reg As Object, s$, i% Dim matchs As Object, match As Object Set reg = CreateObject("vbscript.regexp") reg.Global = True reg.IgnoreCase = True reg.MultiLine = True reg.Pattern = strPattern Set matchs = reg.Execute(strData$) For i = 0 To matchs(0).SubMatches.Count - 1 s = s & matchs(0).SubMatches(i) & "_split_" Next If s <> "" Then s = Left(s, Len(s) - 7) regResult = Split(s, "_split_") Exit Function ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Function: " & vbTab & "regResult", vbExclamation End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' '功能：根据所给文件名和内容直接写文件 '函数名：writeToFile '入口参数(如下)： ' strFileName 所给的文件名； ' strContent 要输入到上述文件的字符串 ' isCover 是否覆盖该文件，默认为覆盖 '返回值：True或False，成功则返回前者，否则返回后者 '备注：sysdzw 于 2007-5-2 提供 '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Function writeToFile(ByVal strFileName$, ByVal strContent$, Optional isCover As Boolean = True) As Boolean On Error GoTo ErrHand Dim fileHandl% fileHandl = FreeFile If isCover Then Open strFileName For Output As #fileHandl Else Open strFileName For Append As #fileHandl End If Print #fileHandl, strContent Close #fileHandl writeToFile = True Exit Function ErrHand: MsgBox "Error Number: " & vbTab & Err.Number & vbCrLf & "Error Description: " & vbTab & Err.Description & vbCrLf & "Error Sub: " & vbTab & "writeToFile", vbExclamation End Function            

 

 

 

v1.0.6设置窗口预览：