麻辣家族討論版版 - Powered by Discuz! Board

'插入一表單(名稱 UserForm1 )的程式碼須有控制項 ComboBox1,ListBox1,ListBox2
Option Explicit
Dim xlFile As String
Private Sub ComboBox1_Change()
If ComboBox1.ListIndex > -1 Then
讀取追蹤檔
Else
ListBox1.Clear
End If
End Sub
Private Sub UserForm_Activate()
xlFile = ActiveWorkbook.Path & 追蹤檔
Caption = ActiveWorkbook.Path & 追蹤檔
If Dir(xlFile) = "" Then
Me.Hide
MsgBox ActiveWorkbook.Path & " 沒有變更的資料追蹤檔 "
Unload Me
Else
表單設定
End If
End Sub
Private Sub 表單設定()
Dim E As String
Top = 66.95
Left = 165.75
Height = 343.85
Width = 552.5
With ListBox1
.Top = 58.9
.Left = 17.65
.Height = 247.5
.Width = 507.45
.ColumnCount = 4
.ColumnWidths = "90,130,130,130"
.Font.Size = 12
End With
With ListBox2
.Top = 35.35
.Left = 17.65
.Height = 21.95
.Width = 507.5
.ColumnCount = 4
.ColumnWidths = "90,130,130,130"
.TextAlign = fmTextAlignCenter
.Font.Size = 16
End With
With ComboBox1
.Top = 11.8
.Left = 17.65
.Height = 15.05
.Width = 94.3
E = Dir(ActiveWorkbook.Path & "\*.XLS")
Do While E <> ""
If E <> ThisWorkbook.Name Then
.AddItem E
End If
E = Dir
Loop
.Value = ActiveWorkbook.Name
End With
End Sub
Private Sub 讀取追蹤檔()
Dim fs As Object, xlWord As Variant, I, E
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.OpenTextFile(xlFile, 1, False)
xlWord = fs.readall
fs.Close
xlWord = Split(xlWord, Chr(10))
With ListBox2
.Clear
.AddItem
For E = 0 To .ColumnCount - 1
.List(.ListCount - 1, E) = Split(xlWord(0), ",")(E)
Next
End With
With ListBox1
.Clear
For I = 1 To UBound(xlWord) - 1
If InStr(xlWord(I), ComboBox1 & "]") Then
.AddItem
For E = 0 To .ColumnCount - 1
.List(.ListCount - 1, E) = Split(xlWord(I), ",")(E)
Next
End If
Next
End With
End Sub

複製代碼

'插入一般模組 (名稱為 Module1 ) 的程式碼
Option Explicit
Public Const 追蹤檔 = "\資料紀錄檔.TXT"
Public Ar(), xlId As CommandBarControl
Dim My_App As New Class1
Private Sub AUTO_CLOSE()
Application.CommandBars.ActiveMenuBar.Reset
End Sub
Private Sub AUTO_Open()
物件設定
新增指令
End Sub
Private Sub 物件設定()
Set My_App.APP = Application
End Sub
Private Sub 新增指令()
With Application.CommandBars.ActiveMenuBar
.Reset '重設功能表
With .Controls.add(10, , , , True) 'msoControlPopup
.Caption = "追蹤指令(&P)"
.TooltipText = "按 Alt + P"
Set xlId = .Controls.add(1) 'msoControlButton
With xlId
.Caption = "資料紀錄檔(&C)"
.OnAction = "追蹤指令"
.TooltipText = "按 Alt + C"
End With
With .Controls.add(1) 'msoControlButton
.Caption = "指令重設(&R)"
.OnAction = "AUTO_Open"
.TooltipText = "按 Alt + R"
End With
End With
End With
MakeAr
End Sub
Sub 追蹤指令()
UserForm1.Show
End Sub
Private Sub MakeAr() '取得工作表資料
Dim ArCell As String, Msg As Boolean
If Workbooks.Count = 0 Then
Msg = True
ElseIf ActiveWorkbook.Name = ThisWorkbook.Name Or ActiveWorkbook.Path = "" Then
Msg = True
ElseIf Dir(ActiveWorkbook.Path & 追蹤檔) = "" Then
Msg = True
End If
If Msg = True Then
xlId.Enabled = False '停止資料紀錄檔
Exit Sub
Else
xlId.Enabled = True '恢復資料紀錄檔
End If
ArCell = Range("A1:" & Cells.SpecialCells(xlCellTypeLastCell).Address).Address
On Error Resume Next
Ar = Application.Transpose(Range(ArCell).Value)
If Err.Number > 0 Then
ReDim Ar(1, 1)
Err.Clear
End If
End Sub

複製代碼

'插入物件類別模組(名稱 Class1 ) 的程式碼
Option Explicit
Public WithEvents APP As Application
Private Sub APP_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim xlErr As Integer, xlUsed As String
If ActiveWorkbook.Name = ThisWorkbook.Name Then Exit Sub
If ActiveWorkbook.Path = "" Then
MsgBox ActiveWorkbook.Name & " 未存檔請先存檔 !"
Exit Sub
End If
xlUsed = Application.UserName
On Error GoTo R
If Target(1).Row <= UBound(Ar, 2) And Target(1).Column <= UBound(Ar, 1) And Ar(Target(1).Column, Target(1).Row) <> "" Then
紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & "," & Ar(Target.Column, Target(1).Row) & "," & Target(1).Value & "," & Application.UserName
Else
紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & ",," & Target(1) & " ," & Application.UserName
End If
R:
xlErr = Err.Number
Run "Module1.MakeAr" 'MakeAr
If xlErr <> 0 Then
If Dir(ActiveWorkbook.Path & 追蹤檔) = "" Then
紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & "," & Target(1) & ", ," & Application.UserName
xlId.Enabled = True
Else
紀錄追蹤 Format(Now, "YYYY/MM/DD HH:NN:SS") & "," & Target(1).Address(0, 0, , 1, 1) & "," & Ar(Target.Column, Target(1).Row) & ", ," & Application.UserName
End If
End If
Err.Clear
Sh.Parent.Save
End Sub
Private Sub APP_SheetActivate(ByVal Sh As Object)
Run "Module1.MakeAr" 'MakeAr
End Sub
Private Sub APP_WorkbookActivate(ByVal Wb As Workbook)
Run "Module1.MakeAr" 'MakeAr
End Sub
Private Sub 紀錄追蹤(xlWord As String) '紀錄變更的資料
Dim fs As Object, xltxt As String, xlFile As String
xlFile = ActiveWorkbook.Path & 追蹤檔
xltxt = Dir(xlFile)
Set fs = CreateObject("Scripting.FileSystemObject")
Set fs = fs.OpenTextFile(xlFile, 8, True)
If xltxt = "" Then
fs.WriteLINE "日期,位置,原本,變更,修改者"
End If
fs.WriteLINE xlWord
fs.Close
End Sub
Private Sub APP_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean)
If Wb.Name <> ThisWorkbook.Name Then Run "Module1.MakeAr" 'MakeAr
End Sub
Private Sub APP_WorkbookOpen(ByVal Wb As Workbook)
Run "Module1.MakeAr" 'MakeAr
End Sub

複製代碼