VB错误处理中心过程,写数据库日志表或写日志文件

 

Option Explicit
Public gstrLogPath As String

Private Sub Class_Initialize()
    gstrLogPath = App.Path & "\Log"     'Log路径
End Sub

'*************************************************************************************************
'*函数名：  WriteErrLog
'*程序功能：写日志
'*开发人员：inrg
'*异动人员：无
'*传入值：  1.strProgramName -- 类模块名
'*          2.strProcName -- 函数名
'*          3.strErrLog -- ErrorLog內容 eg:Err.Description
'*          4.strErrNumber -- Err对象的错误编号（可选） eg:Err.Number
'*          5.strErrDesc -- Err对象的错误描叙（可选） eg:Err.Description
'*回传值：  boolean  成功 = true，失败 = false
'*************************************************************************************************
Public Static Function WriteErrLog(ByVal strProgramName As String, ByVal strProcName As String, ByVal strErrLog As String, Optional ByVal strErrNumber As String, Optional ByVal strErrDesc As String) As Boolean
    Dim FileHandle As Long
    Dim strTxtName As String        '
    Dim FSOLog As Object            '
    
    On Error GoTo WriteLogFileErr:

    Set FSOLog = CreateObject("Scripting.FileSystemObject")
    
    WriteErrLog = True

    If (gstrLogPath = "") Then
        WriteErrLog = False
        GoTo WriteLogFileErr:
    End If
    
    '文件名
    strTxtName = Format(Date, "YYYYMMDD") & ".log"
    
    '判断是否有Log文件夹
    If Dir(gstrLogPath, vbDirectory) = "" Then
            MkDir gstrLogPath
    End If

    FileHandle = FreeFile
    Open (gstrLogPath & "\" & strTxtName) For Append As #FileHandle
    Lock #FileHandle
        Print #FileHandle, "************************************************************************"
        Print #FileHandle, "Date & Time: " & Format(Time, "HH:MM:SS")
        Print #FileHandle, "Program Name: " & strProgramName
        Print #FileHandle, "Procedure Name: " & strProcName
        Print #FileHandle, "Error Number: " & strErrNumber
        Print #FileHandle, "Error Desc: " & strErrDesc
        Print #FileHandle, "Log: " & strErrLog
        Print #FileHandle, "************************************************************************" & vbNewLine
    Unlock #FileHandle
    Close #FileHandle
    
    Set FSOLog = Nothing
    Exit Function

WriteLogFileErr:
        WriteErrLog = False
End Function

 

Public Sub ShowError(strModule As String, strProcedure As String, lngErrorNumber As Long, strErrorDescription As String, showMsg As String)
    '
    '错误处理中心过程,写数据库日志表或写日志文件
    '
    'strModule           '模块名称
    'strProcedure        '过程名称
    'lngErrorNumber      '错误ID号
    'strErrorDescription '错误描述
    'showMsg             '是否显示本过程内错误显示信息(值:"Y" or "N")
    
    'Error表结构(f001 (Date)发生时间,    f002 (nvarchar50)模块名称, f003 (nvarchar50)过程名称, f004 (nvarchar50)错误ID号, _
                 f005 (nvarchar300)错误描述,f006 (nvarchar50)版 本 号, f007 (nvarchar50)用户名称, f008 (nvarchar50)网卡地址
    'ErrorCode表结构 f001 (nvarchar20)错误代码,  f002 (nvarchar255)错误信息, f003 (numeric9)错误级别
    '         级别说明: '10'以下,一般错误,不影响操作
    '                   '11-20',严重错误,不能操作,程序执行退出
    
    On Error GoTo ErrorHandle
    Dim strMessage As String
    Dim strCaption As String
    Dim sVer As String
    Dim intLogFile As Integer
    Dim Res As New ADODB.Recordset
    Dim ResErrorCode As New ADODB.Recordset
    Dim strSQL As String
    
    '对应错误号,从ErrorCode表中找到对应的错误信息,0-1000 错误号保留给VB
    DBOpen ResErrorCode, "select * from errorcode where f001='" & lngErrorNumber & "'"
    If Not (ResErrorCode.EOF Or ResErrorCode.BOF) Then
        strMessage = ResErrorCode.Fields("f002")
        If ResErrorCode.Fields("f003") > 10 Then
            MsgBox "产生一个严重错误,可能影响到系统的可操作性,请立即联系本系统开发人员!", vbCritical, "严重错误"
        End If
    End If
          
    '写错误入文件----------------------------
    
    intLogFile = FreeFile
    Open App.Path & "\" & strIni.LogFile For Append As #intLogFile
    Print #intLogFile, "***错误"; VBA.Now & "*** " & "Version:" & _
          str$(App.Major) & "." & str$(App.Minor) & "." & Format(App.Revision, "0000")
    Print #intLogFile, "Error: " & lngErrorNumber
    Print #intLogFile, "Description: " & strErrorDescription
    Print #intLogFile, "Module: " & strModule
    Print #intLogFile, "Procedure: " & strProcedure
    Print #intLogFile, ""
    Close #intLogFile
    
    If Len(strMessage) > 2 Then strErrorDescription = strMessage
    
    strMessage = "错误: " & "(" & lngErrorNumber & ")" & strErrorDescription & vbCrLf & vbCrLf & _
                 "模块:" & strModule & ";  过程:" & strProcedure 
    sVer = Trim(str$(App.Major) & "." & str$(App.Minor) & "." & _
                 Format(App.Revision, "0000"))
    strCaption = "错误 Version: " & sVer
                           
    '写错误入数据库表--------------------------
    strSQL = "insert into error(f001,f002,f003,f004,f005,f006,f007,f008) values(" _
                & DateFmtB & VBA.Now & DateFmtE & "," _
                & IIf(Len(Trim(strModule)) = 0, "null", "'" & strModule & "'") & "," _
                & IIf(Len(Trim(strProcedure)) = 0, "null", "'" & strProcedure & "'") & "," _
                & IIf(Len(Trim(lngErrorNumber)) = 0, "null", "'" & lngErrorNumber & "'") & "," _
                & IIf(Len(Trim(strErrorDescription)) = 0, "null", "'" & Replace(strErrorDescription, "'", "") & "'") & "," _
                & IIf(Len(Trim(sVer)) = 0, "null", "'" & sVer & "'") & "," _
                & IIf(Len(Trim(sUserName)) = 0, "null", "'" & sUserName & "'") & "," _
                & IIf(Len(Trim(sVer)) = 0, "null", "'" & EthernetNO & "'") & ")"
          
   
    Cn.Execute strSQL
         
    '是否显示未知错误信息
    If Trim(UCase(showMsg)) = "Y" Then MsgBox strMessage, vbCritical, strCaption
    
PROC_EXIT:
    Set Res = Nothing
    Set ResErrorCode = Nothing
    Exit Sub
ErrorHandle:
    Resume Next
End Sub