Option Compare Database
Option Explicit
Private Declare Function api_GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function api_GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function atCNames(UOrC As Integer) As String '获取用户的计算机及帐户
On Error Resume Next
Dim NBuffer As String
Dim Buffsize As Long
Dim Wok As Long
Buffsize = 256
NBuffer = Space$(Buffsize)
If UOrC = 1 Then
Wok = api_GetUserName(NBuffer, Buffsize)
atCNames = Trim$(NBuffer)
Else
Wok = api_GetComputerName(NBuffer, Buffsize)
atCNames = Trim$(NBuffer)
End If
If Right(atCNames, 1) = Chr(0) Then
atCNames = Left(atCNames, Len(atCNames) - 1)
End If
End Function
Public Sub 日志(A As Integer) '进入写入RS系统日志(在当前数据库增加记录)
On Error GoTo Err_A
Dim dbs As Database '数据库
Dim rs As Recordset '代表指定窗体、报表、列表框控件或组合框控件的记录源
Set dbs = CurrentDb 'CurrentDb 方法返回一个类型为 Database 的对象变量
Set rs = dbs.OpenRecordset("XT系统日志") '打开记录源
rs.AddNew '新增记录
If A = 1 Then
rs("类别") = "进入"
ElseIf A = 2 Then
rs("类别") = "退出"
End If
rs("日期") = Now
rs("用户") = Forms![控制面板]!当前用户
rs("帐户") = atCNames(1)
rs("计算机") = atCNames(2)
rs("备注") = Screen.ActiveForm.Name
rs.Update '更新
dbs.Close '关闭数据库
Exit_A:
Exit Sub
Err_A:
If Err.Number <> 0 Then
MsgBox "无法写入系统日志!" & Chr(10) & "错误号:" & Err.Number, vbCritical
End If
Resume Exit_A
End Sub
'**************************************************
'Public Sub 系统日志in() '进入写入记事本
'Dim fs, A
'Set fs = CreateObject("Scripting.FileSystemObject")
'Set A = fs.OpenTextFile(CurrentProject.Path & "\系统日志.txt", 8, 0)
'A.WriteLine ("进入 " & Now & " " & Forms![控制面板]!当前用户 & " " & atCNames(1) & "/" & atCNames(2))
'A.Close
'End Sub