Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Tabelle blinken lassen

Gruppe

OnTime

Problem

Auf Schaltflächendruck soll eine Tabelle zum Blinken gebracht und auf weiteren Schaltlfächedruck soll das Blinken beendet werden.

Lösung
Den nachstehenden Code in ein Standardmodul eingeben, einer Schaltfläche zuweisen und starten.

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