1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269
| '=========================================================================
' 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
' 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 Function
'===================================
' 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
' 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
' *****************************************
' ** Implementation
' *****************************************
Option Explicit
Dim mUndoClass As clsExecAndUndo
Sub MakeAChange()
Dim i As Integer
If mUndoClass Is Nothing Then
Set mUndoClass = New clsExecAndUndo
Else
'Previous undoset, must be removed
Set mUndoClass = Nothing
Set mUndoClass = New clsExecAndUndo
End If
For i = 1 To 10
mUndoClass.AddAndProcessObject ActiveSheet.Cells(i, 1), _
"Interior.Colorindex", 15
Next
Application.OnUndo "Restore colours A1:A10", "UndoChange"
End Sub
Sub UndoChange()
If mUndoClass Is Nothing Then Exit Sub
mUndoClass.UndoAll
Set mUndoClass = Nothing
End Sub
Sub UndoStepwise()
If mUndoClass Is Nothing Then Exit Sub
mUndoClass.UndoLast
If mUndoClass.UndoCount = 0 Then
MsgBox "Last action undone"
Set mUndoClass = Nothing
End If
End Sub |
Partager