GAZZAT5 said:
ok then, how do you get a cell, say d8 to flash red, like you've said above by clicking on a button?
Purists beware.
This lenghty code is one way to answer the literal meaning of your question. Mostly from Hans Herber, a little from me. Increase the range(s) by adding
FlashingRangeCol
line(s) in the first module.
Important, please follow these directions to test this, which flashes a cell's interior color index from red to white like you asked.
Draw 2 forms buttons on the sheet. After inserting the following code as directed, assign the macro StartCellFlasher to one button, and StopCellFlasher to the other button.
Insert 2 new standard modules for this. In one standard module paste this in:
Option Explicit
Sub StartCellFlasher()
Dim FlashingRangeCol As New Collection
FlashingRangeCol.Add Range("D8")
Call fncStartCellFlashing(FlashingRangeCol, 400)
End Sub
Sub StopCellFlasher()
Call fncStopCellFlashing
End Sub
In the other standard module paste in this monster:
Option Explicit
Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" _
( _
ByVal lpClassName As String, _
ByVal lpWindowName As String _
) _
As Long
Private Declare Function SetTimer _
Lib "user32" _
( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long _
) _
As Long
Private Declare Function KillTimer _
Lib "user32" _
( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long _
) _
As Long
Private Declare Function GetCurrentVbaProject _
Lib "vba332.dll" _
Alias "EbGetExecutingProj" _
( _
hProject As Long _
) _
As Long
Private Declare Function GetFuncID _
Lib "vba332.dll" _
Alias "TipGetFunctionId" _
( _
ByVal hProject As Long, _
ByVal strFunctionName As String, _
ByRef strFunctionID As String _
) _
As Long
Private Declare Function GetAddr _
Lib "vba332.dll" _
Alias "TipGetLpfnOfFunctionId" _
( _
ByVal hProject As Long, _
ByVal strFunctionID As String, _
ByRef lpfn As Long _
) _
As Long
Private WindowsTimer As Long
Private FlashingRangeCollection As Collection
Public Function fncStartCellFlashing _
( _
FlashingRangeCol As Collection, _
FlashingPeriod As Integer _
)
fncStopWindowsTimer
Set FlashingRangeCollection = New Collection
Set FlashingRangeCollection = FlashingRangeCol
fncWindowsTimer CLng(FlashingPeriod)
End Function
Public Function fncStopCellFlashing()
Dim aCell As Variant
On Error Resume Next
fncStopWindowsTimer
For Each aCell In FlashingRangeCollection
aCell.Font.Color = 2
Next aCell
Set FlashingRangeCollection = Nothing
End Function
Private Function fncWindowsTimer( _
TimeInterval As Long _
) As Boolean
Dim WindowsTimer As Long
WindowsTimer = 0
If Val(Application.Version) > 8 Then
WindowsTimer = SetTimer _
( _
hWnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf_cbkCustomTimer _
)
Else
WindowsTimer = SetTimer _
( _
hWnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=0, _
uElapse:=TimeInterval, _
lpTimerFunc:=AddrOf("cbkCustomTimer") _
)
End If
fncWindowsTimer = CBool(WindowsTimer)
End Function
Private Function fncStopWindowsTimer()
KillTimer _
hWnd:=FindWindow("XLMAIN", Application.Caption), _
nIDEvent:=WindowsTimer
End Function
Private Function cbkCustomTimer _
( _
ByVal Window_hWnd As Long, _
ByVal WindowsMessage As Long, _
ByVal EventID As Long, _
ByVal SystemTime As Long _
) _
As Long
Dim aCell As Variant
Static aFlag As Boolean
On Error Resume Next
If aFlag = True Then
For Each aCell In FlashingRangeCollection
aCell.Interior.ColorIndex = 3
Next aCell
aFlag = False
Else
For Each aCell In FlashingRangeCollection
aCell.Interior.ColorIndex = 0
Next aCell
aFlag = True
End If
End Function
Private Function AddrOf _
( _
CallbackFunctionName As String _
) _
As Long
'
Dim aResult As Long, CurrentVBProject As Long, strFunctionID As String, _
AddressOfFunction As Long, UniCbkFunctionName As String
'
'convert the name of the function to Unicode system
UniCbkFunctionName = StrConv(CallbackFunctionName, vbUnicode)
'
'if the current VBProjects exists ...
If Not GetCurrentVbaProject(CurrentVBProject) = 0 Then
'... get the function ID of the callback function based on its name, _
in order to ensure that the function exists
aResult = GetFuncID _
( _
hProject:=CurrentVBProject, _
strFunctionName:=UniCbkFunctionName, _
strFunctionID:=strFunctionID _
)
'if the function exists ...
If aResult = 0 Then
'...get a pointer to the callback function based on strFunctionID
aResult = GetAddr _
( _
CurrentVBProject, _
strFunctionID, _
lpfn:=AddressOfFunction _
)
'if we have got the pointer pass it to the result of the function
If aResult = 0 Then
AddrOf = AddressOfFunction
End If
End If
End If
End Function
Function AddrOf_cbkCustomTimer() As Long
AddrOf_cbkCustomTimer = vbaPass(AddressOf cbkCustomTimer)
End Function
Function vbaPass(AddressOfFunction As Long) As Long
vbaPass = AddressOfFunction
End Function