Thema: Tabelle blinken lassen

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

Beiträge aus dem Excel-Forum zu den Themen Ereignis und OnTime