capplog.cls

这是一个实际的工程中所用的源程序

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "CAppLog"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'使用说明:
'
Public Enum eLogRS
    LogRSAdd = -1
    LogRSDel = 0
    LogRSNone = 1
End Enum

Public Enum eLogEvent
    logEvApp = 0
    logEvTechRun = 1
    errRemote = 2
    errPLC = 3
    errBelt = 4
    ErrTechAlarm = 5
    errTechComm = 6
    errPortInterupt = 7
    errABError = 8
End Enum '错误信息
Public Enum eLogType
    LogSys = 0
    LogErr = 1
    LogZero = 2
    logApp = 3
End Enum

Private vPathMdb As String
Private TableName As String
Private isTableExist As Boolean '存在事件表
Private mCntApp As Integer '程序日志
Private mAppIN As Boolean '进入程序
Private mrsActive As ADODB.Recordset
Public Property Get CntAppLog() As Long
    CntAppLog = mCntApp
End Property
Private Sub initRS()
    Set mrsActive = New ADODB.Recordset
    With mrsActive
        .Fields.Append "来源", adVarWChar, 10
        .Fields.Append "事件", adVarWChar, 20
'        .Fields.Append "描述", adLongVarChar, 20
        .Fields.Append "时间", adVarWChar, 20
        .Open
    End With
    mrsActive.Sort = "时间 Desc"
End Sub
Public Property Get ActiveLogRecordSet() As ADODB.Recordset
    Set ActiveLogRecordSet = mrsActive
End Property
Public Sub AppendAppLog(ByVal vType As eLogType, ByVal vSource As String, ByVal vEvent As eLogEvent, Optional ByVal vLogActiveRS As eLogRS = eLogRS.LogRSNone, Optional ByVal vDescription As String = "无描述", Optional ByVal vUser As String = "Admin", Optional ByVal vbSaveMdb As Boolean = False)           '写入日志

    Dim LogFile As Integer
    Dim theLogFile As String
    Dim Loc As Long
    Loc = InStrRev(vPathMdb, "/")
    If Loc = 0 Then
    Loc = InStrRev(vPathMdb, "\") '验证路径字符串
    End If
    theLogFile = Mid(vPathMdb, 1, Loc)
    theLogFile = theLogFile & "Sys" & Format$(Date, "yyMM") & ".log" '日志文件路径
    On Error GoTo err1
    If vEvent = eLogEvent.logEvApp Then
        If mAppIN = True Then
            vDescription = "用户从第 " & CStr(mCntApp) & " 次程序运行中" & vDescription '退出
        Else
            mAppIN = True
            
            mCntApp = mCntApp + 1
            SetReg.SaveSettingInt Sc_AppLog, "Count", mCntApp
            vDescription = "用户第 " & CStr(mCntApp) & " 次" & vDescription '进入
        End If
    End If

    LogFile = FreeFile
    Open theLogFile For Append As #LogFile
    Print #LogFile, "类型:" & nmType(vType)
    Print #LogFile, "时间:" & CStr(Now)
    Print #LogFile, "来源:" & vSource
    Print #LogFile, "事件:" & nmLogEvent(vEvent)
    Print #LogFile, "描述:" & vDescription
    Print #LogFile, "用户:" & vUser
    Print #LogFile, "--------------------------------------------------------"
    Close #LogFile
    '
    If isTableExist And vbSaveMdb Then
    Call cmdInsert(nmType(vType), vSource, nmLogEvent(vEvent), vDescription, vUser)
    End If
    '
    If vLogActiveRS = eLogRS.LogRSAdd Then
        With mrsActive
            .AddNew: .Fields("来源").Value = vSource: .Fields("事件") = nmLogEvent(vEvent): .Fields("时间") = CStr(Now): .Update
        End With
    ElseIf vLogActiveRS = eLogRS.LogRSDel Then
        With mrsActive
            If .RecordCount > 0 Then
               .MoveFirst
               .Find "事件='" & nmLogEvent(vEvent) & "'" '"来源='" & vSource & "'" ' AND
               If .AbsolutePosition > 0 Then
               .Delete
               .Update
               End If
            End If
        End With
    ElseIf vLogActiveRS = eLogRS.LogRSNone Then
    End If

    Exit Sub
err1:
    MsgBox "CSysLog.AppendSysLog" + Chr(13) + Chr(10) + Err.Description, vbExclamation
    Err.Clear
    Resume Next
End Sub



Private Sub cmdInsert(ByVal v类型 As String, ByVal v来源 As String, ByVal v事件 As String, ByVal v描述 As String, ByVal v用户 As String)
Dim strInsert As String

On Error GoTo err1
strInsert = "Insert Into " & TableName & "(类型,时间,来源,事件,描述,用户) Values ('" & v类型 & "'#" & CStr(Now) & "#,'" & v来源 & "','" & v事件 & "','" & v描述 & "','" & v用户 & "')"
CNExecute strInsert, CN_Str40 & vPathMdb, "CAppLog.cmdInsert"
Exit Sub
err1:


    Debug.Assert False
    Call meErr("CAppLog.cmdInsert", Err.Description) ', , , , PATH_Errlog)
    Err.Clear
    Resume Next
End Sub

Private Function meIsTableExist(ByVal vMdbPath As String, ByVal vTableName As String) As Boolean
'用于 CreateCryptogramTable
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim rsSchema As New ADODB.Recordset
    Dim bExistTable As Boolean
    On Error GoTo err1
    If Dir(vMdbPath) = "" Then

        bExistTable = False
    Else
        cn.ConnectionString = CN_Str40 & vMdbPath
        cn.Open
'        cn.Execute "Drop Table tblAppLog"
        rsSchema.ActiveConnection = cn
        Set rsSchema = cn.OpenSchema(adSchemaTables)
        Do Until rsSchema.EOF
            If rsSchema!TABLE_NAME = vTableName Then
                bExistTable = True
                Exit Do
            Else
                bExistTable = False
                rsSchema.MoveNext
            End If
        Loop
exitFunction:
        On Error Resume Next
        rsSchema.Close
        cn.Close
        Set rsSchema = Nothing
        Set cn = Nothing
    End If
    isTableExist = bExistTable
    meIsTableExist = bExistTable
    Exit Function
err1:
    bExistTable = False
    MsgBox ("Error Function meIsExistTable")
    Err.Clear
    Resume exitFunction
End Function

  Private Sub CreateTableDef_tblAppLog(vDatabasePath As String, vTableName As String) 'Mk:库名 idxMk:库中各个表的索引
  '四个班表:tblBan1,tblBan2,tblBan3,tblBan4
'    Dim vTableName As String
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim tdfNew As TableDef
    Dim idfNew As Index
    Dim i As Integer
    Dim MbIndex As String
    Debug.Print "Tables been created!"
    On Error GoTo err1:
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.OpenDatabase(vDatabasePath)


         Set tdfNew = dbsNew.CreateTableDef(vTableName)

         With tdfNew
             .Fields.Append .CreateField("类型", dbText, 10)
             .Fields.Append .CreateField("时间", dbDate)
             .Fields.Append .CreateField("来源", dbText, 30)
             .Fields.Append .CreateField("事件", dbText, 30)
             .Fields.Append .CreateField("描述", dbText, 255)
             .Fields.Append .CreateField("用户", dbText, 30)
             .Fields("类型").AllowZeroLength = True '
             .Fields("来源").AllowZeroLength = True '
             .Fields("事件").AllowZeroLength = True '
             .Fields("描述").AllowZeroLength = True '
             .Fields("用户").AllowZeroLength = True '
       End With
       Dim field_Id As Field

       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex("idx")

       With idfNew
         .Fields.Append .CreateField("时间", dbInteger)
         .Primary = True
         .Unique = True
       End With
       tdfNew.Indexes.Append idfNew

exitSub:

    dbsNew.Close
    Set dbsNew = Nothing
    Set wrkDefault = Nothing

    Exit Sub
err1:
    Call meErr("CreateTableDef_tblAppLog", Err.Description)
    Err.Clear
    Resume exitSub
  End Sub

  Private Sub CreateTableDef_tblAppLogX(vDatabasePath As String, vTableName As String) 'Mk:库名 idxMk:库中各个表的索引
  '四个班表:tblBan1,tblBan2,tblBan3,tblBan4
'    Dim vTableName As String
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim tdfNew As TableDef
    Dim idfNew As Index
    Dim i As Integer
    Dim MbIndex As String
    Debug.Print "Tables been created!"
    On Error GoTo err1:
    Set wrkDefault = DBEngine.Workspaces(0)
    Set dbsNew = wrkDefault.OpenDatabase(vDatabasePath)


         Set tdfNew = dbsNew.CreateTableDef(vTableName)

         With tdfNew
             .Fields.Append .CreateField("Id", dbLong)   '1.
             .Fields.Append .CreateField("编号", dbInteger)   '1.
             .Fields.Append .CreateField("进入时间", dbText, 30)
             .Fields.Append .CreateField("退出时间", dbText, 30)
             .Fields.Append .CreateField("用户名", dbText, 30)
             .Fields("Id").Attributes = dbAutoIncrField '
             .Fields("进入时间").AllowZeroLength = True '
             .Fields("退出时间").AllowZeroLength = True '
             .Fields("用户名").AllowZeroLength = True '

       End With
       Dim field_Id As Field

       dbsNew.TableDefs.Append tdfNew
       '建索引
       Set idfNew = tdfNew.CreateIndex("idx")

       With idfNew
         .Fields.Append .CreateField("Id", dbInteger)
         .Primary = True
         .Unique = True
       End With
       tdfNew.Indexes.Append idfNew

exitSub:

    dbsNew.Close
    Set dbsNew = Nothing
    Set wrkDefault = Nothing

    Exit Sub
err1:
    Call meErr("CreateTableDef_tblAppLog", Err.Description)
    Err.Clear
    Resume exitSub
  End Sub
Private Function initAppLog(ByVal mdbPath As String, Optional ByVal vTableName As String = "tblAppLog") As Boolean
    vPathMdb = mdbPath
    TableName = vTableName '"tblAppLog"
    Dim bOK As Boolean
    If Dir(mdbPath) = "" Then
        bOK = False
        MsgBox "数据库文件" & mdbPath & " 丢失!程序不能储存数据!", vbExclamation
    Else
'        If Not meIsTableExist(mdbPath, TableName) Then
        Call meIsTableExist(mdbPath, TableName)
        If Not isTableExist Then
            If MsgBox("数据表" & TableName & " 丢失!程序不能储存数据!" & Chr(13) & Chr(10) & "要重新创建此文件吗?", vbExclamation + vbYesNo) = vbYes Then
                bOK = True
                Call CreateTableDef_tblAppLog(mdbPath, TableName)                     '创建数据库
            Else
                bOK = False
            End If
        Else
            bOK = True
        End If
    End If
    isTableExist = bOK
    initAppLog = bOK
End Function
Private Function nmLogEvent(ByVal vErr As eLogEvent) As String
    Dim nm As String
    If vErr = eLogEvent.logEvApp Then
                                             nm = "进入程序"
    ElseIf vErr = eLogEvent.logEvTechRun Then:    nm = "仪表运行状态"
    ElseIf vErr = eLogEvent.errRemote Then:       nm = "远程控制失效"
    ElseIf vErr = eLogEvent.errPLC Then:          nm = "出现未知故障"
    ElseIf vErr = eLogEvent.errBelt Then:         nm = "出现皮带跑偏故障"
    ElseIf vErr = eLogEvent.ErrTechAlarm Then:    nm = "仪表产生报警"
    ElseIf vErr = eLogEvent.errTechComm Then:     nm = "仪表通信中断"
    ElseIf vErr = eLogEvent.errPortInterupt Then: nm = "串口通信中断"
    ElseIf vErr = eLogEvent.errABError Then:      nm = "主辅仪表精度误差报警"
    End If:                                       nmLogEvent = nm
End Function
Private Function nmType(ByVal vType As eLogType) As String
    Dim nm As String
    If vType = eLogType.logApp Then
                                            nm = "系统运行"
    ElseIf vType = eLogType.LogErr Then:   nm = "错误日志"
    ElseIf vType = eLogType.LogSys Then:   nm = "程序日志"
    ElseIf vType = eLogType.LogZero Then:  nm = "零点日志"
    End If
End Function
Private Sub Class_Initialize()
mCntApp = SetReg.GetSettingInt(Sc_AppLog, "Count", 0)
Call initRS
'Call initAppLog(PATH_Monitor)
End Sub


Private Sub Class_Terminate()
    On Error Resume Next
    mrsActive.Close
    Set mrsActive = Nothing
End Sub

'========================================