Do trình mình còn yếu và khả năng dịch kém nên không hiểu lắm (có dùng googdich). Nếu được nhờ bạn làm ghi chú giúp mình với. Cảm ơn bạn
'=========================================================================
' Module : clsExecAndUndo
' Company : JKP Application Development Services (c) 2005
' Author : Jan Karel Pieterse
' Created : 31-8-2005
' Purpose : Class module, stores the objects processed and
' handles the exection of the commands
' Copyright : This code is free for you to use for applications
' for personal use.
' It is not allowed to use this for a commercial program,
' unless you have my consent.
' If you want to include this code in freeware, make sure you add :
'-------------------------------------------------------------------------
' This code originates from : Jan Karel Pieterse
' Company : JKP Application Development Services (c) 2005
' www.jkp-ads.com
'-------------------------------------------------------------------------
'=========================================================================
Option Explicit
Private mcolUndoObjects As Collection
Private mUndoObject As clsUndoObject
Public Function AddAndProcessObject(oObj As Object, sProperty As String, vValue As Variant) As Boolean
Set mUndoObject = New clsUndoObject
With mUndoObject
Set .ObjectToChange = oObj
.NewValue = vValue
.PropertyToChange = sProperty
mcolUndoObjects.Add mUndoObject
If .ExecuteCommand = True Then
AddAndProcessObject = True
Else
AddAndProcessObject = False
End If
End With
End Function
Private Sub Class_Initialize()
Set mcolUndoObjects = New Collection
End Sub
Private Sub Class_Terminate()
ResetUndo
End Sub
Public Sub ResetUndo()
While mcolUndoObjects.Count > 0
mcolUndoObjects.Remove (1)
Wend
Set mUndoObject = Nothing
End Sub
Public Sub UndoAll()
Dim lCount As Long
' On Error Resume Next
For lCount = mcolUndoObjects.Count To 1 Step -1
Set mUndoObject = mcolUndoObjects(lCount)
mUndoObject.UndoChange
Set mUndoObject = Nothing
Next
ResetUndo
End Sub
Public Sub UndoLast()
Dim lCount As Long
' On Error Resume Next
If mcolUndoObjects.Count >= 1 Then
Set mUndoObject = mcolUndoObjects(mcolUndoObjects.Count)
mUndoObject.UndoChange
mcolUndoObjects.Remove mcolUndoObjects.Count
Set mUndoObject = Nothing
Else
ResetUndo
End If
End Sub
Public Function UndoCount() As Long
UndoCount = mcolUndoObjects.Count
End Function'=========================================================================
' Module : clsUndoObject
' Company : JKP Application Development Services (c) 2005
' Author : Jan Karel Pieterse
' Created : 31-8-2005
' Purpose : Class module, Contains each object processed and
' handles the exection of the command and the Undo
' Copyright : This code is free for you to use for applications
' for personal use.
' It is not allowed to use this for a commercial program,
' unless you have my consent.
' If you want to include this code in freeware, make sure you add :
'-------------------------------------------------------------------------
' This code originates from : Jan Karel Pieterse
' Company : JKP Application Development Services (c) 2005
' www.jkp-ads.com
'-------------------------------------------------------------------------
'=========================================================================
Option Explicit
Private mUndoObject As Object
Private msProperty As String
Private mvNewValue As Variant
Private mvOldValue As Variant
Public Property Let PropertyToChange(sProperty As String)
msProperty = sProperty
End Property
Public Property Get PropertyToChange() As String
PropertyToChange = msProperty
End Property
Public Property Set ObjectToChange(oObj As Object)
Set mUndoObject = oObj
End Property
Public Property Get ObjectToChange() As Object
Set ObjectToChange = mUndoObject
End Property
Public Property Let NewValue(vValue As Variant)
mvNewValue = vValue
End Property
Public Property Get NewValue() As Variant
NewValue = mvNewValue
End Property
Public Property Let OldValue(vValue As Variant)
mvOldValue = vValue
End Property
Public Property Get OldValue() As Variant
OldValue = mvOldValue
End Property
Public Function ExecuteCommand() As Boolean
ExecuteCommand = False
If mUndoObject Is Nothing Then
End If
If mvNewValue = "" Then
End If
If msProperty = "" Then
End If
If GetOldValue Then
SetNewValue
ExecuteCommand = True
Else
'Failed to retrieve old value!
End If
End Function
Private Function GetOldValue() As Boolean
Dim oTemp As Object
Dim lCount As Long
Dim lProps As Long
Dim vProps As Variant
vProps = Split(PropertyToChange, ".")
lProps = UBound(vProps)
Set oTemp = ObjectToChange
For lCount = 0 To lProps - 1
Set oTemp = CallByName(oTemp, vProps(lCount), VbGet)
Next
If TypeOf oTemp Is Range Then
If LCase(vProps(lProps)) = "value" Then
vProps(lProps) = "Formula"
End If
End If
OldValue = CallByName(oTemp, vProps(lProps), VbGet)
If Err.Number = 0 Then
GetOldValue = True
Else
GetOldValue = False
End If
End Function
Private Function SetNewValue() As Boolean
Dim oTemp As Object
Dim lCount As Long
Dim lProps As Long
Dim vProps As Variant
Dim vResult As Variant
Err.Clear
Set oTemp = ObjectToChange
vProps = Split(PropertyToChange, ".")
lProps = UBound(vProps)
For lCount = 0 To lProps - 1
Set oTemp = CallByName(oTemp, vProps(lCount), VbGet)
Next
If TypeOf oTemp Is Range Then
If LCase(vProps(lProps)) = "value" Then
vProps(lProps) = "Formula"
End If
End If
vResult = CallByName(oTemp, vProps(lProps), VbLet, NewValue)
If Err.Number = 0 Then
SetNewValue = True
Else
SetNewValue = False
End If
End Function
Public Function UndoChange()
Dim oTemp As Object
Dim lCount As Long
Dim lProps As Long
Dim vProps As Variant
Dim vResult As Variant
Set oTemp = ObjectToChange
vProps = Split(PropertyToChange, ".")
lProps = UBound(vProps)
For lCount = 0 To lProps - 1
Set oTemp = CallByName(oTemp, vProps(lCount), VbGet)
Next
If TypeOf oTemp Is Range Then
If LCase(vProps(lProps)) = "value" Then
vProps(lProps) = "Formula"
End If
End If
vResult = CallByName(oTemp, vProps(lProps), VbLet, OldValue)
If vResult <> "" Then
UndoChange = True
Else
UndoChange = False
End If
End FunctionOption Explicit
Dim mUndoClass As clsExecAndUndoIf mUndoClass Is Nothing Then
Set mUndoClass = New clsExecAndUndo
Else
'Previous undoset, must be removed
Set mUndoClass = Nothing
Set mUndoClass = New clsExecAndUndo
End IfmUndoClass.AddAndProcessObjectIf mUndoClass Is Nothing Then Exit Sub
mUndoClass.UndoAll
Set mUndoClass = NothingIf mUndoClass Is Nothing Then Exit Sub
mUndoClass.UndoLast
If mUndoClass.UndoCount = 0 Then
MsgBox "Đây là hành động cuối cùng"
Set mUndoClass = Nothing
End IfCảm ơn bạn. Như vậy dễ hiểu hơn nhiều.
