351 lines
11 KiB
Plaintext
351 lines
11 KiB
Plaintext
Option Compare Database
|
||
Option Explicit
|
||
|
||
' === 模块级变量 ===
|
||
Private m_IsNewRecord As Boolean
|
||
Private m_DeletedIDs As New Collection
|
||
|
||
' === 安全的字符串转义 ===
|
||
Private Function SafeSQL(txt As String) As String
|
||
SafeSQL = Replace(txt, "'", "''") ' SQL标准转义
|
||
End Function
|
||
|
||
' === 获取窗体数据源表名 (修复版) ===
|
||
Private Function GetFormTableName() As String
|
||
On Error Resume Next
|
||
Dim tableName As String
|
||
|
||
' 方法 1: 【最推荐】直接检查主键字段的来源表
|
||
' 既然你的查询里有 "缺件记录.ID"，那么 ID 字段的 SourceTable 属性就是 "缺件记录"
|
||
' 这比解析字符串准确得多，也不怕查询改名
|
||
tableName = Me.Recordset.Fields("ID").SourceTable
|
||
|
||
' 如果方法1成功，直接返回
|
||
If Len(tableName) > 0 Then
|
||
GetFormTableName = tableName
|
||
Exit Function
|
||
End If
|
||
|
||
' 方法 2: 检查窗体的 UniqueTable 属性
|
||
' Access 经常在属性表中设置这个值来指定多表查询中哪个表可更新
|
||
tableName = Me.UniqueTable
|
||
If Len(tableName) > 0 Then
|
||
GetFormTableName = tableName
|
||
Exit Function
|
||
End If
|
||
|
||
' 方法 3: (保底方案) 解析 RecordSource 字符串
|
||
' 只有当上面都失败时，才尝试去解析 SQL
|
||
Dim recordSource As String
|
||
recordSource = Trim(Me.recordSource & "")
|
||
|
||
' 如果是保存的查询名（不含SELECT），需要先获取查询的SQL
|
||
If InStr(UCase(recordSource), "SELECT") = 0 Then
|
||
' 检查是否为查询对象
|
||
Dim qdf As DAO.QueryDef
|
||
Set qdf = CurrentDb.QueryDefs(recordSource)
|
||
If Not qdf Is Nothing Then
|
||
recordSource = qdf.sql ' 获取查询背后的真实 SQL
|
||
Else
|
||
' 既不是SELECT又不是查询，那只能是直接的表名了
|
||
GetFormTableName = recordSource
|
||
Exit Function
|
||
End If
|
||
Set qdf = Nothing
|
||
End If
|
||
|
||
' 解析 SQL: 提取 FROM 之后、JOIN 之前的第一个词
|
||
Dim fromPos As Long
|
||
fromPos = InStr(1, UCase(recordSource), " FROM ", vbTextCompare)
|
||
|
||
If fromPos > 0 Then
|
||
Dim tempStr As String
|
||
tempStr = Mid(recordSource, fromPos + 6) ' 跳过 " FROM "
|
||
tempStr = Trim(tempStr)
|
||
|
||
' 截断点：遇到 JOIN, WHERE, ORDER BY, GROUP BY 或逗号时停止
|
||
Dim stopChars As Variant
|
||
Dim i As Integer, minPos As Long, p As Long
|
||
stopChars = Array(" LEFT ", " RIGHT ", " INNER ", " OUTER ", " JOIN ", " WHERE ", " ORDER ", " GROUP ", ",")
|
||
|
||
minPos = Len(tempStr) + 1
|
||
|
||
For i = LBound(stopChars) To UBound(stopChars)
|
||
p = InStr(1, UCase(tempStr), stopChars(i), vbTextCompare)
|
||
If p > 0 And p < minPos Then minPos = p
|
||
Next i
|
||
|
||
tableName = Trim(Left(tempStr, minPos - 1))
|
||
|
||
' 清理括号
|
||
tableName = Replace(tableName, "[", "")
|
||
tableName = Replace(tableName, "]", "")
|
||
End If
|
||
|
||
' 默认值
|
||
If Len(tableName) = 0 Then tableName = "UnknownTable"
|
||
|
||
GetFormTableName = tableName
|
||
On Error GoTo 0
|
||
End Function
|
||
|
||
' === 获取表地址(连接字符串或本地路径) ===
|
||
Private Function GetTableAddress(tableName As String) As String
|
||
On Error Resume Next
|
||
Dim db As DAO.Database
|
||
Dim tdf As DAO.TableDef
|
||
Dim address As String
|
||
|
||
Set db = CurrentDb
|
||
Set tdf = db.TableDefs(tableName)
|
||
|
||
If Not tdf Is Nothing Then
|
||
If Len(Trim(tdf.Connect & "")) > 0 Then
|
||
' 链接表:返回连接字符串
|
||
address = tdf.Connect
|
||
Else
|
||
' 本地表:返回当前数据库路径
|
||
address = "LOCAL:" & CurrentDb.Name
|
||
End If
|
||
Else
|
||
address = "UNKNOWN"
|
||
End If
|
||
|
||
' 清理过长的连接字符串(可选)
|
||
If Len(address) > 500 Then
|
||
address = Left(address, 500) & "..."
|
||
End If
|
||
|
||
GetTableAddress = address
|
||
|
||
Set tdf = Nothing
|
||
Set db = Nothing
|
||
On Error GoTo 0
|
||
End Function
|
||
|
||
' === 获取表类型 ===
|
||
Private Function GetTableType(tableName As String) As String
|
||
On Error Resume Next
|
||
Dim db As DAO.Database
|
||
Dim tdf As DAO.TableDef
|
||
Dim connectStr As String
|
||
Dim tableType As String
|
||
|
||
Set db = CurrentDb
|
||
Set tdf = db.TableDefs(tableName)
|
||
|
||
If Not tdf Is Nothing Then
|
||
connectStr = UCase(Trim(tdf.Connect & ""))
|
||
|
||
If Len(connectStr) = 0 Then
|
||
' 本地表
|
||
tableType = "LOCAL"
|
||
ElseIf InStr(connectStr, "ODBC;") > 0 Then
|
||
' ODBC链接表
|
||
If InStr(connectStr, "SQL SERVER") > 0 Then
|
||
tableType = "LINKED_SQLSERVER"
|
||
ElseIf InStr(connectStr, "MYSQL") > 0 Then
|
||
tableType = "LINKED_MYSQL"
|
||
ElseIf InStr(connectStr, "ORACLE") > 0 Then
|
||
tableType = "LINKED_ORACLE"
|
||
Else
|
||
tableType = "LINKED_ODBC"
|
||
End If
|
||
ElseIf InStr(connectStr, "MS ACCESS") > 0 Or InStr(connectStr, ".ACCDB") > 0 Or InStr(connectStr, ".MDB") > 0 Then
|
||
' Access链接表
|
||
tableType = "LINKED_ACCESS"
|
||
ElseIf InStr(connectStr, "EXCEL") > 0 Or InStr(connectStr, ".XLS") > 0 Then
|
||
' Excel链接表
|
||
tableType = "LINKED_EXCEL"
|
||
ElseIf InStr(connectStr, "TEXT;") > 0 Or InStr(connectStr, ".TXT") > 0 Or InStr(connectStr, ".CSV") > 0 Then
|
||
' 文本/CSV链接表
|
||
tableType = "LINKED_TEXT"
|
||
Else
|
||
' 其他类型链接表
|
||
tableType = "LINKED_OTHER"
|
||
End If
|
||
Else
|
||
tableType = "UNKNOWN"
|
||
End If
|
||
|
||
GetTableType = tableType
|
||
|
||
Set tdf = Nothing
|
||
Set db = Nothing
|
||
On Error GoTo 0
|
||
End Function
|
||
|
||
' === 获取本机IP地址(带超时保护) ===
|
||
Private Function GetLocalIPAddress() As String
|
||
On Error Resume Next
|
||
Dim objWMI As Object
|
||
Dim colItems As Object
|
||
Dim objItem As Object
|
||
Dim ip As String
|
||
Dim startTime As Double
|
||
|
||
startTime = Timer
|
||
Set objWMI = GetObject("winmgmts:\\.\root\cimv2")
|
||
|
||
' 超时保护:WMI查询最多等待2秒
|
||
If Timer - startTime > 2 Then
|
||
GetLocalIPAddress = "127.0.0.1"
|
||
Exit Function
|
||
End If
|
||
|
||
Set colItems = objWMI.ExecQuery("SELECT IPAddress FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
|
||
|
||
For Each objItem In colItems
|
||
If Not IsNull(objItem.ipAddress) Then
|
||
ip = objItem.ipAddress(0)
|
||
If InStr(ip, ":") = 0 Then
|
||
GetLocalIPAddress = ip
|
||
Exit Function
|
||
End If
|
||
End If
|
||
Next
|
||
|
||
GetLocalIPAddress = "127.0.0.1"
|
||
On Error GoTo 0
|
||
End Function
|
||
|
||
' === 异步日志写入(不阻塞用户操作) ===
|
||
Private Sub WriteLog(actionType As String, recordID As String)
|
||
Dim sql As String
|
||
Dim ipAddr As String
|
||
Dim remoteTable As String
|
||
Dim localTable As String
|
||
Dim tableAddr As String
|
||
Dim tableType As String
|
||
Dim computerName As String ' 新增：计算机名称变量
|
||
' --- 配置区域 ---
|
||
remoteTable = "dbo_TableChangeLog"
|
||
' ----------------
|
||
|
||
' 【关键1】立即返回,不等待耗时操作
|
||
On Error Resume Next
|
||
|
||
' 【新增】动态获取窗体数据源表名
|
||
localTable = GetFormTableName()
|
||
|
||
' 【新增】动态获取表地址
|
||
tableAddr = GetTableAddress(localTable)
|
||
|
||
' 【新增】动态获取表类型
|
||
tableType = GetTableType(localTable)
|
||
|
||
' 快速验证:表是否存在
|
||
If IsNull(DLookup("Name", "MSysObjects", "Name='" & SafeSQL(remoteTable) & "'")) Then
|
||
Debug.Print "Log Warning: 表 " & remoteTable & " 不存在,跳过日志"
|
||
Exit Sub
|
||
End If
|
||
|
||
' 【关键2】防止空值和特殊字符
|
||
If Len(Trim(recordID & "")) = 0 Then recordID = "NULL"
|
||
recordID = SafeSQL(recordID)
|
||
|
||
' 【关键3】快速获取IP(带缓存)
|
||
Static cachedIP As String
|
||
If cachedIP = "" Then cachedIP = GetLocalIPAddress()
|
||
ipAddr = cachedIP
|
||
|
||
' 获取当前电脑的【计算机名称】，替代原有的 Windows登录用户名
|
||
computerName = Environ$("COMPUTERNAME")
|
||
|
||
|
||
' 【关键4】参数化查询(如果支持)或安全拼接
|
||
' 注意:不写 ChangeDate 字段,让 SQL Server 的 DEFAULT GETDATE() 自动填充
|
||
sql = "INSERT INTO " & remoteTable & " " & _
|
||
"(TableName, TableAddress, TableType, RecordID, ActionType, IPAddress, UserName, FilePath) " & _
|
||
"VALUES ('" & SafeSQL(localTable) & "', " & _
|
||
"'" & SafeSQL(tableAddr) & "', " & _
|
||
"'" & SafeSQL(tableType) & "', " & _
|
||
"'" & recordID & "', " & _
|
||
"'" & SafeSQL(actionType) & "', " & _
|
||
"'" & SafeSQL(ipAddr) & "', " & _
|
||
"'" & SafeSQL(computerName) & "', " & _
|
||
"'" & SafeSQL(CurrentDb.Name) & "')"
|
||
|
||
' 【关键5】静默执行,绝不影响用户
|
||
CurrentDb.Execute sql ' 移除 dbFailOnError!
|
||
|
||
If Err.Number <> 0 Then
|
||
' 仅记录到立即窗口,不弹窗
|
||
Debug.Print Now & " - Log Failed: " & Err.Description & " | SQL: " & sql
|
||
' 可选:写入本地备份表
|
||
Call WriteLocalBackupLog(localTable, recordID, actionType)
|
||
End If
|
||
|
||
On Error GoTo 0
|
||
End Sub
|
||
|
||
' === 本地备份日志(防止远程失败) ===
|
||
Private Sub WriteLocalBackupLog(tblName As String, recID As String, actType As String)
|
||
On Error Resume Next
|
||
' Access 本地表使用 Now() 函数
|
||
CurrentDb.Execute "INSERT INTO LocalLogBackup (TableName, RecordID, ActionType, LogTime) " & _
|
||
"VALUES ('" & SafeSQL(tblName) & "', '" & SafeSQL(recID) & "', '" & SafeSQL(actType) & "', Now())"
|
||
On Error GoTo 0
|
||
End Sub
|
||
|
||
' ==============================
|
||
' 窗体事件逻辑(增强版)
|
||
' ==============================
|
||
|
||
' 1. 保存前状态判断
|
||
Private Sub Form_BeforeUpdate(Cancel As Integer)
|
||
On Error Resume Next ' 【保护】防止日志逻辑影响保存
|
||
m_IsNewRecord = Me.NewRecord
|
||
On Error GoTo 0
|
||
End Sub
|
||
|
||
' 2. 修改保存后
|
||
Private Sub Form_AfterUpdate()
|
||
On Error Resume Next
|
||
If Not m_IsNewRecord Then
|
||
Call WriteLog("UPDATE", Nz(Me.ID.Value, ""))
|
||
End If
|
||
On Error GoTo 0
|
||
End Sub
|
||
|
||
' 3. 新增确认后
|
||
Private Sub Form_AfterInsert()
|
||
On Error Resume Next
|
||
Call WriteLog("INSERT", Nz(Me.ID.Value, ""))
|
||
m_IsNewRecord = False
|
||
On Error GoTo 0
|
||
End Sub
|
||
|
||
' 4. 删除开始(收集ID)
|
||
Private Sub Form_Delete(Cancel As Integer)
|
||
On Error Resume Next
|
||
If Not IsNull(Me.ID.Value) Then
|
||
m_DeletedIDs.Add CStr(Me.ID.Value)
|
||
End If
|
||
On Error GoTo 0
|
||
End Sub
|
||
|
||
' 5. 删除确认后(批量写入)
|
||
Private Sub Form_AfterDelConfirm(Status As Integer)
|
||
On Error Resume Next
|
||
Dim vID As Variant
|
||
|
||
If Status = acDeleteOK Then
|
||
For Each vID In m_DeletedIDs
|
||
Call WriteLog("DELETE", CStr(vID))
|
||
Next
|
||
End If
|
||
|
||
' 清理集合
|
||
Set m_DeletedIDs = Nothing
|
||
Set m_DeletedIDs = New Collection
|
||
On Error GoTo 0
|
||
End Sub
|
||
|
||
' === 窗体关闭时清理(可选) ===
|
||
Private Sub Form_Unload(Cancel As Integer)
|
||
On Error Resume Next
|
||
Set m_DeletedIDs = Nothing
|
||
On Error GoTo 0
|
||
End Sub
|