用一下 on error goto Private Sub Command1_Click() On Error GoTo er '…… '…… '…… Exit Sub er: MsgBox "运行过程中出错" '这里的文字你自己随便写 End Sub
Private Sub Command1_Click() On Error GoTo er '…… '…… '…… Exit Sub er: MsgBox "运行过程中出错" '这里的文字你自己随便写 End Sub
Option ExplicitPrivate Sub Form_Load() On Error GoTo errSub
Exit Sub errSub: MsgBox "装在窗体出错,错误号:" & Err.Number & ";错误描述:" & Err.Description, vbOKOnly + vbExclamation End Sub
On Error GoTo e e: MsgBox"装在窗体出错,错误号:"& Err.Number&";错误描述:"& Err.Description, vbOKOnly+ vbExclamation
给你看看我的出错处理例子Public Function DownLoadFile(ByRef sURL As String, ByRef SaveFile As String, ByVal GlobalRootPath As String, ByVal GlobalKMLPath As String) As Boolean '<EhHeader> On Error GoTo DownLoadFile_Err '</EhHeader>
'下载之前需要处理地址 Dim bGISInit As Boolean Dim lRet As Long
If dictDownLoadFile Is Nothing Then Set dictDownLoadFile = New Scripting.Dictionary End If
100 sURL = LTrim$(sURL) 102 If LCase(Left(sURL, 4)) = "http" Or LCase(Left(sURL, 4)) = "file" Then Else 104 If Left$(sURL, 1) = "/" Then 106 sURL = GlobalRootPath & Right(sURL, Len(sURL) - 1) 108 ElseIf mID(sURL, 2, 1) = ":" Then 'sUrl = sUrl Else
110 sURL = GlobalKMLPath & sURL End If End If
'避免重复下载,使用缓冲 112 If dictDownLoadFile.Exists(sURL) = False Then 114 GoSub labDownLoad Else 116 SaveFile = dictDownLoadFile.Item(sURL) 118 If Dir(SaveFile, vbNormal) <> "" Then
120 DownLoadFile = True Else 122 GoSub labDownLoad End If End If DownLoadFile = True GoTo FunctionEnd:
labDownLoad: 'On Error Resume Next
'如果存在该文件则先删除 If Dir(SaveFile) <> "" Then FileSystem.Kill SaveFile End If If Err.Number <> 0 Then
End If Randomize If InStr(sURL, "?") > 0 Then lRet = URLDownloadToFile(0, sURL & "&showen=" & Rnd, SaveFile, 0, 0) Else lRet = URLDownloadToFile(0, sURL & "?showen=" & Rnd, SaveFile, 0, 0) End If 128 'DownLoadFile = m_Download.DownloadFileWaitReturn(sURL, SaveFile)
130 If Dir(SaveFile, vbNormal) <> "" Then 'DownLoadFile Then 156 If dictDownLoadFile.Exists(sURL) = False Then 158 dictDownLoadFile.Add sURL, SaveFile End If Else '下载失败使用默认图片162 If dictDownLoadFile.Exists(sURL) = False Then 164 dictDownLoadFile.Add sURL, SaveFile End If End If 166 Return '<EhFooter> GoTo FunctionEndDownLoadFile_Err: DownLoadFile = False fMsgboxExp err.Number, err, err.description, _ "ModuleFunction.DownLoadFile Error by " & Erl & " Line" GoTo FunctionEnd Resume FunctionEnd: '</EhFooter> End FunctionfMsgboxExp 是自定义消息弹出函数
Private Sub Command1_Click() On Error GoTo er '…… '…… '…… Exit Sub er: MsgBox "运行过程中出错" '这里的文字你自己随便写 End Sub
其实说白了就是 用到了 onerror goto**挺基础的,就是捕捉到了错误,就goto了。
可能出错的地方都写上on error goto xxx
我习惯在生成程序的时候把每一句加上ON ERROR RESUME NEXT 当然调试的时候不建议这么加,因为会跳过很多要处理的未知错误!
rem 自己写的集中错误处理模块: rem 用法: Call InitProErr(err,"自定义错误源",调试模式) rem 自己再改改,希望你能看懂-_-||| rem 说明:这个模块会保存一个日志,以供分析。Public Function InitProErr(ByRef ErrObj As ErrObject, ByVal ErrSource As String, ByVal IsDebug As Boolean) As Boolean Rem Transfer arglist to ProErr InitProErr = False InitProErr = Core(ErrObj, IsDebug, ErrSource) End FunctionPrivate Function Core(ByRef ErrObj As ErrObject, ByVal IsDebug As Boolean, ByVal ErrSource As String) As Boolean
Dim Bdy As String, Hed As String, NF As Integer, tmp As String, K As Boolean
tmp = "lc=" & App.Path & "\" & App.EXEName & ".exe" tmp = tmp & " pi=" & App.PrevInstance tmp = tmp & " pn=" & App.ProductName tmp = tmp & " vr=" & App.Major & "," & App.Minor & "," & App.Revision tmp = tmp & " nm=" & ErrObj.Number tmp = tmp & " es=" & ErrObj.Source tmp = tmp & " ps=" & ErrSource tmp = tmp & " dt=" & Now If IsDebug = True Then Hed = "调试模式-已识别的错误-集中错误处理程序" Bdy = ErrObj.Number & vbCrLf & ErrObj.Description & vbCrLf & "ObjSor " & ErrObj.Source & vbCrLf & "StrSor " & ErrSource Core = False Select Case ErrObj.Number Case 11 Core = True K = True Case Else Hed = "调试模式-未识别的错误-集中错误处理程序" K = False End Select Dim tmpFileName As String NF = FreeFile tmp = tmp & " kn=" & K tmpFileName = Date & "_" & CLng(Timer) Open App.Path & "\错误报告debug" & tmpFileName & ".txt" For Random Access Read Write Lock Read Write As NF Len = 32767 Put NF, , tmp Close NF NF = 0 Else Hed = "错误" Core = False Select Case ErrObj.Number Case 11 Core = True Bdy = "错误解释:" & "假装除以零" & vbCrLf K = True Case Else Hed = "未知错误" Bdy = "" K = False End Select tmp = tmp & " kn=" & K Bdy = "“" & App.ProductName & "”运行时遇到了问题,我们对此表示抱歉。" & vbCrLf & "如果您正在工作,未保存的信息有可能丢失。" & vbCrLf & Bdy & "请将以下信息或程序目录下的“错误报告.report”发送到<邮箱>中,谢谢!" NF = FreeFile Open App.Path & "\错误报告.report.txt" For Random Access Read Write Lock Read Write As NF Len = 32767 Put NF, , tmp Close NF NF = 0 Bdy = Bdy & vbCrLf & tmp End If MsgBox Bdy, vbOKOnly + vbSystemModal + vbCritical, Hed ErrObj.ClearEnd Function
Private Sub Command1_Click()
On Error GoTo er
'……
'……
'……
Exit Sub
er:
MsgBox "运行过程中出错" '这里的文字你自己随便写
End Sub
On Error GoTo er
'……
'……
'……
Exit Sub
er:
MsgBox "运行过程中出错" '这里的文字你自己随便写
End Sub
On Error GoTo errSub
Exit Sub
errSub:
MsgBox "装在窗体出错,错误号:" & Err.Number & ";错误描述:" & Err.Description, vbOKOnly + vbExclamation
End Sub
e:
MsgBox"装在窗体出错,错误号:"& Err.Number&";错误描述:"& Err.Description, vbOKOnly+ vbExclamation
'<EhHeader>
On Error GoTo DownLoadFile_Err
'</EhHeader>
'下载之前需要处理地址
Dim bGISInit As Boolean
Dim lRet As Long
If dictDownLoadFile Is Nothing Then
Set dictDownLoadFile = New Scripting.Dictionary
End If
100 sURL = LTrim$(sURL)
102 If LCase(Left(sURL, 4)) = "http" Or LCase(Left(sURL, 4)) = "file" Then
Else
104 If Left$(sURL, 1) = "/" Then
106 sURL = GlobalRootPath & Right(sURL, Len(sURL) - 1)
108 ElseIf mID(sURL, 2, 1) = ":" Then
'sUrl = sUrl
Else
110 sURL = GlobalKMLPath & sURL
End If
End If
'避免重复下载,使用缓冲
112 If dictDownLoadFile.Exists(sURL) = False Then
114 GoSub labDownLoad
Else
116 SaveFile = dictDownLoadFile.Item(sURL)
118 If Dir(SaveFile, vbNormal) <> "" Then
120 DownLoadFile = True
Else
122 GoSub labDownLoad
End If
End If
DownLoadFile = True
GoTo FunctionEnd:
labDownLoad:
'On Error Resume Next
'如果存在该文件则先删除
If Dir(SaveFile) <> "" Then
FileSystem.Kill SaveFile
End If
If Err.Number <> 0 Then
End If
Randomize
If InStr(sURL, "?") > 0 Then
lRet = URLDownloadToFile(0, sURL & "&showen=" & Rnd, SaveFile, 0, 0)
Else
lRet = URLDownloadToFile(0, sURL & "?showen=" & Rnd, SaveFile, 0, 0)
End If
128 'DownLoadFile = m_Download.DownloadFileWaitReturn(sURL, SaveFile)
130 If Dir(SaveFile, vbNormal) <> "" Then 'DownLoadFile Then
156 If dictDownLoadFile.Exists(sURL) = False Then
158 dictDownLoadFile.Add sURL, SaveFile
End If
Else '下载失败使用默认图片162 If dictDownLoadFile.Exists(sURL) = False Then
164 dictDownLoadFile.Add sURL, SaveFile
End If
End If
166 Return '<EhFooter>
GoTo FunctionEndDownLoadFile_Err:
DownLoadFile = False
fMsgboxExp err.Number, err, err.description, _
"ModuleFunction.DownLoadFile Error by " & Erl & " Line"
GoTo FunctionEnd
Resume
FunctionEnd:
'</EhFooter>
End FunctionfMsgboxExp 是自定义消息弹出函数
On Error GoTo er
'……
'……
'……
Exit Sub
er:
MsgBox "运行过程中出错" '这里的文字你自己随便写
End Sub
当然调试的时候不建议这么加,因为会跳过很多要处理的未知错误!
rem 用法: Call InitProErr(err,"自定义错误源",调试模式)
rem 自己再改改,希望你能看懂-_-|||
rem 说明:这个模块会保存一个日志,以供分析。Public Function InitProErr(ByRef ErrObj As ErrObject, ByVal ErrSource As String, ByVal IsDebug As Boolean) As Boolean
Rem Transfer arglist to ProErr
InitProErr = False
InitProErr = Core(ErrObj, IsDebug, ErrSource)
End FunctionPrivate Function Core(ByRef ErrObj As ErrObject, ByVal IsDebug As Boolean, ByVal ErrSource As String) As Boolean
Dim Bdy As String, Hed As String, NF As Integer, tmp As String, K As Boolean
tmp = "lc=" & App.Path & "\" & App.EXEName & ".exe"
tmp = tmp & " pi=" & App.PrevInstance
tmp = tmp & " pn=" & App.ProductName
tmp = tmp & " vr=" & App.Major & "," & App.Minor & "," & App.Revision
tmp = tmp & " nm=" & ErrObj.Number
tmp = tmp & " es=" & ErrObj.Source
tmp = tmp & " ps=" & ErrSource
tmp = tmp & " dt=" & Now If IsDebug = True Then Hed = "调试模式-已识别的错误-集中错误处理程序"
Bdy = ErrObj.Number & vbCrLf & ErrObj.Description & vbCrLf & "ObjSor " & ErrObj.Source & vbCrLf & "StrSor " & ErrSource
Core = False
Select Case ErrObj.Number
Case 11
Core = True
K = True
Case Else
Hed = "调试模式-未识别的错误-集中错误处理程序"
K = False
End Select
Dim tmpFileName As String
NF = FreeFile
tmp = tmp & " kn=" & K
tmpFileName = Date & "_" & CLng(Timer)
Open App.Path & "\错误报告debug" & tmpFileName & ".txt" For Random Access Read Write Lock Read Write As NF Len = 32767
Put NF, , tmp
Close NF
NF = 0 Else Hed = "错误"
Core = False
Select Case ErrObj.Number
Case 11
Core = True
Bdy = "错误解释:" & "假装除以零" & vbCrLf
K = True
Case Else
Hed = "未知错误"
Bdy = ""
K = False
End Select
tmp = tmp & " kn=" & K
Bdy = "“" & App.ProductName & "”运行时遇到了问题,我们对此表示抱歉。" & vbCrLf & "如果您正在工作,未保存的信息有可能丢失。" & vbCrLf & Bdy & "请将以下信息或程序目录下的“错误报告.report”发送到<邮箱>中,谢谢!"
NF = FreeFile
Open App.Path & "\错误报告.report.txt" For Random Access Read Write Lock Read Write As NF Len = 32767
Put NF, , tmp
Close NF
NF = 0
Bdy = Bdy & vbCrLf & tmp End If MsgBox Bdy, vbOKOnly + vbSystemModal + vbCritical, Hed
ErrObj.ClearEnd Function
如下:
'错误处理中心
'
'参数:
' oErr 必选。表示错误的对象
' sCaption 必选。表示标题
' eInfoStyle 可选。表示信息的样式(vbCritical、vbInformation 及 vbExclamation)
'返回值:
' 暂无
Public Function iErrorManageentCenter(ByVal oErr As Object, ByVal sCaption As String, Optional ByVal eInfoStyle As VbMsgBoxStyle = vbInformation) As Long
If (MsgBox("执行操作时发生未预期错误。" & vbCrLf & "详细信息:" & oErr.Description & " <" & CStr(oErr.Number) & ">", vbOKCancel + eInfoStyle, sCaption) = vbOK) Then
'可以在此加入写入日志的代码……
End If
End FunctionPrivate Sub mySub()
On Error GoTo userErr '
'您的代码...
'
Exit SubuserErr:
'出错后由“错误处理中心”来处理
Call iErrorManageentCenter(Err, Me.Caption, vbExclamation)
End Sub