Highlighten von Excelzellen

[volti]

Liebe Leserin, lieber Leser,

für die Zellen bzw. Bereiche auf einem Tabellenblatt gibt es im Gegensatz zu Active-X Controls wie CommandButtons oder Checkboxen, die sich auf einem Tabellenblatt oder in einer Userform befinden, keine Mousemove-Eigenschaft.

Wer trotzdem beim Überfahren einzelner Zellen oder Bereiche mit der Maus bestimmte Aktionen durchführen möchte, z.B. um ein Highlighting darstellen zu können, der kann dieses unter Zuhilfenahme der Windows-API
realisieren.

Es gibt mindestens zwei Versionen, um die Mausaktions-Sub aufzurufen.

Die Timer-Version:
Wir kreieren einen Timer mit einem möglichst kleinem Intervall und weisen dem Timer die TimerProc zu.
Diese wird dann periodisch aufgerufen.

Die Mousehooking-Version:
Nach dem Setzen des Mousehooks werden die Mausmeldungen von Windows direkt an unsere MouseProc-Sub geschickt. Die gewünschten Meldungen, z.B. Mousemove oder Mousedown usw., fischen wir raus und leiten die Meldungen dann weiter an Excel.

Bei beiden Methoden erfolgt die Weiterverarbeitung gleich.
Mausposition ermitteln, darunter liegende Excelrange ermitteln und anhand einer gültigen Excelrange unsere gewünschten Aktionen durchführen.

Da es hier dann aber schier unendlich viele Möglichkeiten gibt, nachfolgend mal ein Beispiel für Zellen-Highlighting.
Die Aktivitäten habe ich vom Mousemove-Prozess mal getrennt. Da kann man dann ja auch machen, was man will.
In der anliegende Datei sind beide Methoden beispielhaft enthalten.

Wichtig: Sowohl für die Timerversion als auch für die Hookingmethode gilt, nach Verlassen des Blattes, spätestens beim Schließen oder der Deaktivierung der Mappe immer den Timer bzw. das Hooking abschalten.
Diese gehören nämlich zu Windows und nicht zu Excel und müssen sauber beendet werden.

Hinweis: Die "Buttons" werden anhand der Hintergrundfarbe erkannt, natürlich kann man auch die Felder anderweitig vorgeben oder alles ganz anders machen... 


  HighLight-Mouseover.xlsb (Größe: 38,58 KB / Downloads: 7)

So, und nun viel Spaß und Erfolg beim Testen....

Code:

Option Explicit
Private Const bHooking As Boolean = True                ' An- Abschalten der Funktionalität

Private Declare PtrSafe Function SetWindowsHookExA Lib "user32" ( _
        ByVal idHook As Long, ByVal lpfn As LongPtr, _
        ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, ByVal nCode As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
        lpPoint As POINTAPI) As Long

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Dim hHook                   As LongPtr                  ' Handle des Hooking
Dim PT As POINTAPI, oCurObj As Range
Dim msLastRange             As String                   ' Letztes Highlight-Feld
Private Const csActiveRange As String = "B1:D13"        ' Aktiven Bereich vorgeben
Private Const tblTab        As String = "Mousehooking"  ' Tabellenblatt, in dem Mousehooking stattfindet
Private Const iUnHighLight  As Long = 15790320          ' Hellgrau RGB(240,240,240)
Private Const iHighLight    As Long = 65535             ' Gelb     RGB(255,255,0)

Public Sub StartHighlight()
  If bHooking = False Then Exit Sub                     ' Kein Hooking gewünscht
  If ActiveSheet.Name <> tblTab Then Exit Sub           ' Highlightning nur auf gewünschtem Blatt
  If hHook = 0 Then                                     ' Baut den Mousehook auf
     hHook = SetWindowsHookExA(14, AddressOf MouseProc, _
             Application.HinstancePtr, 0)               ' 14 = WH_MOUSE_LL
  End If
End Sub

Public Sub StopHighlight()
  UnhookWindowsHookEx hHook: hHook = 0                  ' Beendet den Mousehook
End Sub

Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, _
                           lParam As LongPtr) As LongPtr
  On Error GoTo Fehler

  If nCode = &H0 And wParam = &H200 Then '&H0=HC_ACTION, &H200=WM_MOUSEMOVE
    
     GetCursorPos PT                                        ' Mausposition holen
    
     Set oCurObj = ActiveWindow.RangeFromPoint(PT.X, PT.Y)  ' Objekt unter der Maus
     If Not oCurObj Is Nothing Then
        If TypeOf oCurObj Is Range And oCurObj.MergeArea.Address <> msLastRange Then
           Call MausAction(oCurObj)                         ' Ist es eine Range?
        End If
     End If
  End If
Fehler:
  MouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam) ' Mousemessages an Excel weitergeben

End Function

Private Sub MausAction(rRng As Range)
' Abarbeitung der Highlight-Funktion
' Hier nach Feldhintergrundfarben

' Highlightning im aktiven Bereich
  
  If Not Intersect(Range(csActiveRange), rRng) Is Nothing Then
     If rRng.MergeArea.Interior.Color = iUnHighLight Then
        rRng.MergeArea.Interior.Color = iHighLight
     End If
  End If
    
' Highlight aus
  If msLastRange <> "" Then
     With Sheets(tblTab).Range(msLastRange).Interior
         If .Color = iHighLight Then
            .Color = iUnHighLight
         End If
     End With
  End If
  If rRng.MergeArea.Interior.Color = iHighLight Then
      Application.Cursor = xlNorthwestArrow
  Else
     Application.Cursor = xlDefault
  End If
  msLastRange = rRng.MergeArea.Address
End Sub

_________
viele Grüße
Karl-Heinz

[volti]

Nachtrag:

Das Highlighten der Excelfelder ist auch bei im Hintergrund liegendem bzw. inaktivem Excelfenster weiterhin aktiv.
Die Funktionalität ist, sowohl beim Mousehooking wie auch bei der Timerversion, dass alle Mousemessages für Excel über die eingehookte, eigene Prozedur geleitet werden, auch wenn Excel nicht im Vordergrund liegt.


Falls das, aus welchem Grund auch immer, nicht gewünscht ist, kann man z.B. durch Abfragen des Vordergrundfensters oder des aktiven Fensters  ggf. Abhilfe schaffen.

Mit folgender Ergänzung erfolgt das Highlighten nur bei aktiven Excel:

Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
....
If nCode = &H0 And wParam = &H200 And GetForegroundWindow = Application.hwnd Then '&H0=HC_ACTION, &H200=WM_MOUSEMOVE

Das Mousehooking bleibt dabei jedoch weiterhin eingeschaltet.

Mit ein paar weiteren API-Funktionen kann das Mousehooking während der Inaktivität von Excel auch ganz abgeschaltet werden.
Das heißt, beim Verlassen von Excel wird das Mousehooking abgeschaltet und bei Wiederaktivierung von Excel wieder eingeschaltet.

Positiv ist hierbei auch, dass bei Aktivierung des VBA-Bereichs das Mousehooking ebenfalls ausgeschaltet wird, was beim Arbeiten am Code zu mehr Sicherheit führt.

Nachfolgend der ergänzte Code und eine aktualisierte Datei.


  HighLight-Mouseover.xlsb (Größe: 44,32 KB / Downloads: 3)

Code:

Option Explicit
Private Const bHooking As Boolean = True                    ' An- Abschalten der Funktionalität

Private Declare PtrSafe Function SetWindowsHookExA Lib "user32" ( _
        ByVal idHook As Long, ByVal lpfn As LongPtr, _
        ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, ByVal nCode As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
        lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function SetWinEventHook Lib "user32" ( _
        ByVal eventMin As Long, ByVal eventMax As Long, _
        ByVal hmodWinEventProc As LongPtr, _
        ByVal lpfnWinEventProc As LongPtr, ByVal idProcess As Long, _
        ByVal idThread As Long, ByVal dwflags As Long) As LongPtr
Private Declare PtrSafe Function UnhookWinEvent Lib "user32" ( _
        ByVal hWinEventHook As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Dim hCurWin                 As LongPtr                      ' Handle de aktiven Fensters
Dim hHook                   As LongPtr                      ' Handle des Mouse-Hooking
Dim hEventHook              As LongPtr                      ' Handle des Eventhooking
Dim PT As POINTAPI, oCurObj As Range
Dim msLastRange             As String                       ' Letztes Highlight-Feld
Private Const csActiveRange As String = "B1:D13"            ' Aktiven Bereich vorgeben
Private Const tblTab        As String = "Mousehooking"      ' Tabellenblatt, in dem Mousehooking stattfindet
Private Const iUnHighLight  As Long = 15790320              ' Hellgrau RGB(240,240,240)
Private Const iHighLight    As Long = 65535                 ' Gelb     RGB(255,255,0)
Private Const EVENT_SYSTEM_FOREGROUND_ = 3

Public Sub StartHighlight()
  If bHooking = False Then Exit Sub                         ' Kein Hooking gewünscht
  If ActiveSheet.Name <> tblTab Then Exit Sub               ' Highlighting nur auf gewünschtem Blatt
  hCurWin = GetActiveWindow
  If hEventHook = 0 Then
     hEventHook = SetWinEventHook(3, 3, 0, AddressOf EventProc, 0, 0, 0)
     Call StartMouse                                        ' Mousehooking sarten
  End If
End Sub

Public Sub StartMouse()
  If hHook = 0 Then                                         ' Baut den Mousehook auf
     hHook = SetWindowsHookExA(14, AddressOf MouseProc, _
             Application.HinstancePtr, 0)                   ' 14 = WH_MOUSE_LL
  End If
End Sub

Sub StopHighlight()
  UnhookWinEvent hEventHook: hEventHook = 0                 ' Beendet den Eventhook
  UnhookWindowsHookEx hHook: hHook = 0                      ' Mausgesten stoppen
End Sub

Private Function EventProc(ByVal hWinEventHook As LongPtr, ByVal WinEvent As Long, _
                 ByVal hwnd As LongPtr, ByVal idObject As Long, ByVal idChild As Long, _
                 ByVal dwEventThread As Long, ByVal dwmsEventTime As Long) As Long
  If hwnd = Application.hwnd Then
     Call StartMouse                                        ' Excel wieder aktiv?
  Else
     If hCurWin = Application.hwnd Then
        UnhookWindowsHookEx hHook: hHook = 0                ' Mausgesten stoppen
     End If
  End If
  hCurWin = GetActiveWindow
End Function

Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, _
                           lParam As LongPtr) As LongPtr
  On Error GoTo Fehler

  If nCode = &H0 And wParam = &H200 Then '&H0=HC_ACTION, &H200=WM_MOUSEMOVE
    
     GetCursorPos PT                                        ' Mausposition holen
    
     Set oCurObj = ActiveWindow.RangeFromPoint(PT.X, PT.Y)  ' Objekt unter der Maus
     If Not oCurObj Is Nothing Then
        If TypeOf oCurObj Is Range And oCurObj.MergeArea.Address <> msLastRange Then
           Call MausAction(oCurObj)                         ' Ist es eine Range?
        End If
     End If
  End If
Fehler:
  MouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam) ' Mousemessages an Excel weitergeben

End Function

Private Sub MausAction(rRng As Range)
' Abarbeitung der Highlight-Funktion
' Hier nach Feldhintergrundfarben

' Highlighting im aktiven Bereich
  
  If Not Intersect(Range(csActiveRange), rRng) Is Nothing Then
     If rRng.MergeArea.Interior.Color = iUnHighLight Then
        rRng.MergeArea.Interior.Color = iHighLight
     End If
  End If
    
' Highlight aus
  If msLastRange <> "" Then
     With Sheets(tblTab).Range(msLastRange).Interior
         If .Color = iHighLight Then
            .Color = iUnHighLight
         End If
     End With
  End If
  If rRng.MergeArea.Interior.Color = iHighLight Then
      Application.Cursor = xlNorthwestArrow
  Else
      Application.Cursor = xlDefault
  End If
  msLastRange = rRng.MergeArea.Address
End Sub

_________
viele Grüße
Karl-Heinz