Gruppe
Ereignis
Problem
Auf Schaltflächendruck soll eine Tabelle zum Blinken gebracht und auf weiteren Schaltlfächedruck soll das Blinken beendet werden.
StandardModule: Modul1
Sub StartCellFlasher()
Dim FlashingRangeCol As New Collection
FlashingRangeCol.Add Range("A1")
FlashingRangeCol.Add Range("A3")
FlashingRangeCol.Add Range("B10")
FlashingRangeCol.Add Range("C14")
FlashingRangeCol.Add Range("C15:D36")
FlashingRangeCol.Add Range("E5:E125")
Call fncStartCellFlashing(FlashingRangeCol, 400)
End Sub
Sub StopCellFlasher()
Call fncStopCellFlashing
End Sub
StandardModule: modCellFlasher
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 = vbBlack
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.Font.Color = vbBlack
Next aCell
aFlag = False
Else
For Each aCell In FlashingRangeCollection
aCell.Font.Color = aCell.Interior.Color
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