Excel Audit Vb

Option Explicit

Private OldVal As Variant

'========== 请务必改成你自己的超强密码 ==========
Private Const SHEET_PASSWORD As String = "x9#kP2@mZqW8!vN4L&"   ' 工作表保护密码
Private Const VBA_PASSWORD As String = "A1b#9xY7@zQ2wE5rT8uI"       ' VBA工程锁密码（可选）

Private Sub Workbook_Open()
    Application.OnTime Now + TimeValue("00:00:01"), "ReApplyProtection"
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Call ReApplyProtection
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call ReApplyProtection
    ThisWorkbook.Save
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.CountLarge = 1 Then
        If Not Target.Locked Then
            OldVal = Target.Value
        Else
            OldVal = vbNullString
        End If
    Else
        OldVal = vbNullString
    End If
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim c As Range
    Dim LogWs As Worksheet
    Dim NextRow As Long
    Dim sUser As String, sTime As String, OldStr As String, NewStr As String
    
    On Error GoTo CleanUp
    Application.EnableEvents = False
    
    Set LogWs = ThisWorkbook.Worksheets("ChangeLogHidden")
    sUser = Environ("USERNAME") & " (" & Application.UserName & ")"
    sTime = Format(Now, "yyyy-mm-dd HH:mm:ss")
    
    For Each c In Target.Cells
        If c.Locked Then GoTo NextC
        
        OldStr = Nz(OldVal)
        NewStr = Nz(c.Value)
        
        If OldStr = NewStr And OldVal <> vbNullString Then GoTo NextC
        
        NextRow = LogWs.Cells(LogWs.Rows.Count, 1).End(xlUp).Row + 1
        
        With LogWs
            .Cells(NextRow, 1) = Sh.Name & "!" & c.Address(False, False)
            .Cells(NextRow, 2) = sUser
            With .Cells(NextRow, 3)
                .ClearFormats
                .NumberFormat = "@"
                .Value = sTime
                .Font.Size = 10
            End With
            .Cells(NextRow, 4) = OldStr & " → " & NewStr
        End With
        
NextC:
        OldVal = vbNullString
    Next c
    
CleanUp:
    Application.EnableEvents = True
End Sub

Private Function Nz(v As Variant) As String
    If IsEmpty(v) Or IsNull(v) Or IsError(v) Then
        Nz = ""
    Else
        Nz = CStr(v)
    End If
End Function

Public Sub ReApplyProtection()
    Dim ws As Worksheet
    Dim pwd As String: pwd = "x9#kP2@mZqW8!vN4L&"   ' 必须和 ThisWorkbook 里的一致
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    On Error Resume Next
    For Each ws In ThisWorkbook.Worksheets
        ws.Unprotect pwd
        ws.Unprotect
    ' 双保险
    Next ws
    On Error GoTo 0
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "ChangeLogHidden" Then
            ws.Protect Password:=pwd, _
                       DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                       UserInterfaceOnly:=True, _
                       AllowFormattingCells:=True, AllowFormattingColumns:=True, AllowFormattingRows:=True
        Else
            ws.Visible = xlSheetVeryHidden   ' 超级隐藏
        End If
    Next ws
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

'========== 管理员后门：查看日志 ==========
Public Sub 查看修改日志()
    Dim pwd As String
    pwd = InputBox("请输入管理员密码查看日志", "管理员权限")
    If pwd = "8888" Then   ' ← 改成你喜欢的密码
        With ThisWorkbook.Worksheets("ChangeLogHidden")
            .Visible = xlSheetVisible
            .Activate
        End With
        MsgBox "查看完毕后关闭文件会自动重新隐藏", vbInformation
    Else
        MsgBox "密码错误", vbCritical
    End If
End Sub

'========== 一键导出日志到桌面 ==========
Public Sub 导出修改日志()
    Dim pwd As String
    pwd = InputBox("请输入管理员密码导出日志", "管理员权限")
    If pwd <> "8888" Then
        MsgBox "密码错误", vbCritical: Exit Sub
    End If
    
    Dim LogWs As Worksheet, wbNew As Workbook, SavePath As String
    Set LogWs = ThisWorkbook.Worksheets("ChangeLogHidden")
    
    SavePath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\修改日志_" & Format(Now, "yyyymmdd_HHMMSS") & ".xlsx"
    
    LogWs.Copy
    Set wbNew = ActiveWorkbook
    With wbNew.Worksheets(1)
        .Range("A1").CurrentRegion.Columns.AutoFit
        .Rows(1).Font.Bold = True
    End With
    ActiveWindow.FreezePanes = False
    wbNew.Worksheets(1).Rows("2:2").Select
    ActiveWindow.FreezePanes = True
    
    wbNew.SaveAs SavePath, 51 '51 = xlsx
    wbNew.Close False
    MsgBox "已导出到桌面：" & SavePath, vbInformation
End Sub
Public Sub 修复时间格式()
    Dim LogWs As Worksheet, LastRow As Long, i As Long
    Set LogWs = ThisWorkbook.Worksheets("ChangeLogHidden")
    LastRow = LogWs.Cells(LogWs.Rows.Count, 1).End(xlUp).Row
    
    With LogWs
        .Range("C2:C" & LastRow).NumberFormat = "@"
        For i = 2 To LastRow
            If IsNumeric(.Cells(i, 3).Value) Then
                .Cells(i, 3).Value = Format(.Cells(i, 3).Value, "yyyy-mm-dd HH:MM:SS")
            End If
        Next i
        .Columns("A:D").AutoFit
    End With
    MsgBox "所有时间已永久修复为文字格式！", vbInformation
End Sub