Info-ToolTip über ausgewählten Zellen anzeigen

[volti]

Liebe Leserin, lieber Leser,

hat man eine umfangreiche Liste und möchte man beim Lesen gerne Zusatzinformationen haben, die sich aber auf einem anderen Blatt befinden, so könnte man diese in einem kleinen PopUp-Fenster temporär neben dem aktuellen Feld anzeigen lassen.

Es besteht z.B. die Möglichkeit, für jedes relevante Feld (per VBA) einmalig oder ggf. mit gelegentlichen Updates Notizen anzulegen, die dann automatisch beim Überfahren des Feldes angezeigt werden.
Oder man zeigt nach einem Feldwechsel über das Event SelectionChange eine Notiz an oder kreiert eine eigene Textbox. Diese würde nach einem weiteren Feldwechsel wieder verschwinden.

Mit diesem Beitrag möchte ich aber eine weitere Möglichkeit zeigen, die mit einem eher echten Mouseover eine selbst gestaltete Textbox für die Dauer des Mausaufenthalts über dem besagten Feld anzeigt.

Nicht zu verschweigen sei hierbei, dass diese Methode etwas zeitintensiver ist als die anderen beiden Methoden.
Deshalb werden zwei Tickzeiten verwendet.

Eine längere Tickzeit von z.B. 800 mSec, wenn kein ToolTip aktiv ist.
Es dauert dann 800 mSec bis zur Anzeige. Bei schnellen Mausbewegungen werden dann nicht ständig Textboxen aufgemacht.
Und der Rechner ist weniger belastet.

Eine kürzere Tickzeit von z.B. 80 mSec.
Damit verschwindet bei Verlassen des Textfeldes der Tooltip recht zügig.

Über die Events Activate und DeActivate kann die Funktionalität auf beliebige Blätter begrenzt werden.

Code:

Private Sub Worksheet_Activate()
  Call StartPopUp       ' PopUp aktivieren
End Sub

Private Sub Worksheet_Deactivate()
  Call StopPopUp       ' PopUp deaktivieren
End Sub

Außerdem kann zur weiteren Ressourcenschonung ein begrenzter Bereich und/oder ein bestimmtes Suchmuster vorgegeben werden.

Wichtig ist das Abschalten des PopPup beim Schließen der Arbeitsmappe mittels des Events BeforeClose.


Hinweis
Der Code ist etwas umfangreicher, weil auch ein Fensterhandling eingebaut wurde.
Bei Aktivierung einer anderen Anwendung als Excel wird die Funktionalität bis zur Reaktivierung der Mappe abgeschaltet.
Das gilt auch für den VBA-Editor. So kann man auch bequem weiterprogrammieren. 

Übrigens, die generierte Textbox kannst Du nach eigenen Vorstellungen anpassen.

Hier auch noch eine Datei zum Ausprobieren....

  PopUpUeberZelle.xlsb (Größe: 53,73 KB / Downloads: 2)

Und der Mustercode:

Code:

Option Explicit

' ###    Einstellungen    ###
Private Const mbTooltip     As Boolean = True               ' An- Abschalten der Funktionalität, z.B. für Wartungsarbeiten
Private Const csSuch        As String = "[EI]*"             ' Suchmuster, * = egal
Private Const csActiveRange As String = "*"                 ' Aktiven Bereich vorgeben, * = alles
Private Const csDataRange   As String = "Daten!A:A"         ' Datenblatt und Bereich mit den PopUp-Daten
Private Const ciSpalte      As Integer = 2                  ' Spalte im Datenblatt mit den PopUp-Texten
Private Const ciBMax        As Integer = 0                  ' Feste Kästchenbreite vorgeben 0=auto
Private Const ciFontGross   As Integer = 10                 ' Schriftgröße, 9 ist normal
Private Const ciTickTime    As Long = 800                   ' Verzögerung Box-Anzeige in mSec
' ### Ende Einstellungen ###

Private Declare PtrSafe Function SetTimer Lib "user32.dll" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
        ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32.dll" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
        ByRef 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 mhCurWin    As LongPtr                                  ' Handle de aktiven Fensters
Dim mhEventHook As LongPtr                                  ' Handle des Eventhooking
Dim mhTimer     As LongPtr                                  ' Handle des Hooking
Dim moCurObj    As Range
Dim msLastRange As String                                   ' Letztes PopUp-Feld
Dim mbAktiv     As Boolean

Public Sub StartPopUp()
  If mbTooltip = False Then Exit Sub                        ' Kein PopUp gewünscht =>raus
  Call ToolTip_Delete                                       ' Ggf. altes Tooltip löschen
  mhCurWin = GetActiveWindow                                ' Gerade aktives Fenster
  If mhEventHook = 0 Then
     mhEventHook = SetWinEventHook(3, 3, 0, AddressOf EventProc, 0, 0, 0)
     Call StartTimer                                        ' Mausabfragen starten
  End If
End Sub

Public Sub StopPopUp()                                      ' Beendet den Eventhook und Timer
  If mhEventHook <> 0 Then UnhookWinEvent mhEventHook: mhEventHook = 0
  Call StopTimer                                            ' Timer löschen
  Call ToolTip_Delete                                       ' Ggf. Tooltip löschen
End Sub

Private Sub StartTimer()
  If mhTimer = 0 Then                                       ' Timer starten
     mhTimer = SetTimer(0, 0, IIf(mbAktiv, 80, ciTickTime), AddressOf TimerTick)
  End If
End Sub

Private Sub StopTimer()
  If mhTimer <> 0 Then KillTimer 0&, mhTimer: mhTimer = 0   ' Timer löschen
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 StartTimer
  Else
     If mhCurWin = Application.hwnd Then Call StopTimer     ' Mausgesten/Timer stoppen
  End If
  mhCurWin = GetActiveWindow
End Function

Private Sub TimerTick()
' Diese Sub wird periodisch aufgerufen
  Dim Pt As POINTAPI, rngBer As Range
 
  DoEvents
  GetCursorPos Pt                                           ' Mausposition holen
  On Error Resume Next
 
  Set moCurObj = ActiveWindow.RangeFromPoint(Pt.X, Pt.Y)    ' Objekt unter Maus
  If Err <> 0 Then Err.Clear: Exit Sub                      ' Fehler => raus

  If TypeOf moCurObj Is Range Then                          ' Ist es eine Range?
     With moCurObj
         If .MergeArea.Address <> msLastRange Then          ' Maus jetzt auf anderem Range?
            msLastRange = .MergeArea.Address                ' Alte Range-Adresse merken
            If mbAktiv = True Then
               Call StopTimer:   mbAktiv = False
               Call ToolTip_Delete                          ' Tooltip löschen
            End If
            
            If Len(csActiveRange) > 1 Then                  ' Aktiven Bereich setzen
               Set rngBer = Range(csActiveRange)
            Else
               Set rngBer = ActiveSheet.UsedRange
            End If
' PopUp anzeigen
            If Not Intersect(rngBer, moCurObj) Is Nothing And mbAktiv = False _
               And .Value Like csSuch And .Value <> "" Then
               Call StopTimer:   mbAktiv = True
               Call Tooltip_Create(moCurObj)                ' Tooltip erstellen
            End If
            Call StartTimer                                 ' Timer neu starten
         End If
     End With
  End If
End Sub

Sub ToolTip_Delete()
  On Error Resume Next
  ActiveSheet.Shapes.Range("ToolTip").Delete                ' Evtl. vorhandene Textbox löschen
End Sub


Sub Tooltip_Create(oRng As Range)
' Hier das Objekt formatieren oder ggf. etwas anderes programmieren
  Dim WSh As Worksheet
  Dim sText As String, sArr() As String, t As String
  Dim Y As Integer, X As Integer, B As Integer, H As Integer, L As Currency
  Dim i As Integer, j As Integer, iGefunden As Long

  On Error Resume Next
  Set WSh = Sheets(Split(csDataRange, "!")(0))              ' Datenblatt setzen
  If WSh Is Nothing Then Exit Sub                           ' Datenblatt nicht gefunden =>raus

  With oRng
      sText = .MergeArea.Cells(1, 1).Value                  ' Suchtext holen
      If sText = "" Then Exit Sub                           ' Kein Text=>raus
      iGefunden = Application.WorksheetFunction.Match(sText, _
                  WSh.Range(Split(csDataRange, "!")(1)), 0) ' Suchbegriff suchen
      If iGefunden = 0 Then Exit Sub                        ' Suchtext nicht gefunden =>raus
      sText = WSh.Cells(iGefunden, ciSpalte).Value          ' Tooltip-Text holen
      sText = Replace(sText, "¶", vbLf)                     ' Textumbrüche setzen
      sArr = Split(sText, vbLf)                             ' Text in Array
      
      For i = 0 To UBound(sArr)
          If ciBMax = 0 Then
             L = 0
             For j = 1 To Len(sArr(i))                      ' Textbreite je Zeile ermitteln
                 t = Mid$(sArr(i), j, 1)
                 L = L + 2.75
                 If InStr(1, Chr$(34) & " !/()\''|,;.:1ijl", t, vbTextCompare) = 0 Then L = L + 2.5
                 If InStr(1, Chr$(34) & "wm_", t, vbTextCompare) > 0 Then L = L + 0.75
                 If Asc(t) > 64 And Asc(t) < 97 Then L = L + 1.5
              Next j
              If L > B Then B = L                           ' Textboxlänge ermitteln
          End If
          H = H + 12                                        ' Zeilenhöhe
      Next i
      B = B * ciFontGross \ 9
      If ciBMax > 0 Then B = ciBMax                         ' Feste Breitenvorgabe
  
      Call ToolTip_Delete                                   ' Evtl. vorhandenes Tooltip löschen
      Y = .Top + 1: X = .Offset(0, 1).Left + 2              ' Box positionieren

' Tooltip: Anzeigebox erstellen <<< Parameter ggf. hier anpassen >>>
      With .Parent.Shapes.AddTextbox(1, X, Y, B, H)
          .Name = "ToolTip"
          .Visible = msoTrue                                ' ToolTip sichtbar
          With .TextFrame2.TextRange
               .Font.Fill.ForeColor.RGB = RGB(255, 255, 160)
               .Font.Size = ciFontGross
               .Font.Name = "Arial"
               .Text = sText
          End With
          With .Fill
               .ForeColor.RGB = RGB(0, 0, 100)              ' Hintergrundfarbe setzen
               .Solid
          End With
          With .TextFrame2
               .AutoSize = msoAutoSizeShapeToFitText        ' Textboxgröße automatisch
               .MarginLeft = 1.5:   .MarginTop = 1.5        ' Randabstände
               .MarginBottom = 1.5: .MarginRight = 1.5      ' Randabstände
          End With
      End With
  End With
End Sub

_________
viele Grüße
Karl-Heinz