Tooltips für Active-X Controls auf Tabellenblätter

[volti]

Liebe Leserin, lieber Leser,

im Gegensatz zu Controls auf einer Userform haben Active-X Controls wie CommandButtons oder Checkboxen, die sich auf einem Tabellenblatt befinden, keine Tooltip-Eigenschaft.

Wer trotzdem beim Überfahren dieser Objekte mit der Maus auch hier einen PopUp-Hinweis geben möchte, findet nachfolgend mal zwei Beispiele für eine entsprechende  Realiserung.

Man kann sich über die API selbst kleine Textboxen programmieren oder aber, wie in den hier vorgestellten Fällen, einfach eine Textbox einfügen und mit Excel-Bordmitteln so gestalten, wie es gewünscht ist.
Mit dem ersten MouseMove (Event) auf dem betroffenen Control wird die gewünschte Textbox erstellt und nach Verlassen des Controls wieder gelöscht.
Da es aber für das Verlassen des Controls kein passendes Event gibt, setzen wir einfach einen Timer, in dessen TimerProc das Verlassen des Controls geprüft wird.
Anschließend werden der Timer und die Textbox wieder ausgeschaltet.
PS: Der Timer muss auf jeden Fall ausgeschaltet werden, deshalb bitte auch bei Verlassen der Tabelle und ggf. beim Schließen der Mappe dieses sicher stellen. (KillTimer)

Wenn man nur ein oder wenige Objekte oder auch auf mehreren Blättern befindliche Objekte mit einem Tooltip versehen möchte, kommt Methode 1 zum Tragen. Hier wird für jedes gewünschte Control eine eigene MouseMove-Prozedur vorgehalten.

Möchte man sehr viele CommandButtons mit Tooltips ausstatten, kann man sich mit der Methode 2 der Klassenprogrammierung bedienen. Hierfür benötigen wir dann das Klassenmodul und die Sub Tooltip-Initiate

PS:  Die Tooltiptexte selbst werden hier im Beispiel direkt im Code vorgehalten. Kann man natürlich auch anders machen.


  ButtonTooltips.xlsb (Größe: 57,39 KB / Downloads: 21)

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

Code:

' #### In ein Codemodul ####
Option Explicit

Private Declare PtrSafe Function SetTimer Lib "user32" ( _
        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" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent 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 Pt     As POINTAPI

Private hTimer As LongPtr, oCurObj As Object

Dim msOldBtnText As String

Sub Tooltip_Create(oButton As Object, X As Single, ByVal Y As Single)
' Hier das Objekt formatieren
  Dim sText As String, B As Integer, H As Integer, L As Currency
  Dim sArr() As String, i As Integer, j As Integer, iBMax As Long
  Dim T As String
  
  If hTimer <> 0 Then Exit Sub                          ' Timer läuft noch
  On Error Goto Fehler

  With oButton
     msOldBtnText = .Name
     Select Case .Name

' ##### Hier die Vorgabe der Tooltiptexte #####
' ¶ = CHR$(182) = Umbruchplatzhalter
' iBMax = Vorgabe der Textboxbreite, wenn 0, dann automatisch _
Ermittlung
     Case "CommandButton1": sText = "Dieses ist mein erster Tooltip!":         iBMax = 122
     Case "CommandButton2": sText = "Und hier¶machen wir einen Umbruch mit rein!"
     Case "CheckBox1":      sText = "Für weitere Informationen hier klicken!": iBMax = 156
' #############################################
    
     Case Else: Exit Sub
     End Select

     sText = Replace(sText, "¶", vbLf)                  ' Textumbrüche setzen
     sArr = Split(sText, vbLf)
     For i = 0 To UBound(sArr)
       If iBMax = 0 Then
          L = 0
          For j = 1 To Len(sArr(i))                     ' Textbreite 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
     Next i
     If iBMax > 0 Then B = iBMax                        ' Feste Breitenvorgabe
  
     Call ToolTip_Delete(.Parent)                       ' Evtl. vorhandene Tooltipbox löschen
     Y = .Top + .Height + 2 + (Y \ 2)
     X = .Left + X
     With .Parent.Shapes.AddTextbox(1, X, Y, B, H)
        .Name = "ToolTip"
        With .TextFrame2.TextRange.Characters
             .Font.Size = 9
             .Font.Name = "Arial"
             .Text = sText
        End With
        With .Fill
             .Visible = msoTrue
             .ForeColor.RGB = RGB(255, 255, 210)        ' Hintergrundfarbe setzen
             .Transparency = 0
             .Solid
        End With
        With .TextFrame2
           .AutoSize = msoAutoSizeShapeToFitText        ' Textboxgröße automatisch
           .MarginLeft = 1.5:   .MarginTop = 1.5        ' Randabstände
           .MarginBottom = 1.5: .MarginRight = 1.5
        End With
     End With
  End With
  
  hTimer = SetTimer(0&, 0&, 10, AddressOf Timer_Tick)   ' Timer setzen für nächsten Check
Fehler:
End Sub

Sub Timer_Tick()
  DoEvents
  GetCursorPos Pt                                       ' Mausposition holen
  On Error Resume Next
  Set oCurObj = Application.Windows(1).RangeFromPoint(Pt.X, Pt.Y)
  If Err <> 0 Then Err.Clear: Exit Sub                  ' Fehler => raus

  If TypeName(oCurObj) = "OLEObject" Then
     If msOldBtnText <> oCurObj.Name Then
        Call ToolTip_Delete(oCurObj.Parent)             ' Textbox löschen
        Call Tooltip_Create(oCurObj, oCurObj.X, oCurObj.Y)
     End If
  Else
     Call ToolTip_Delete(ActiveSheet)                   ' Textbox löschen
  End If
End Sub

Sub ToolTip_Delete(WSh As Worksheet)
  If hTimer <> 0 Then KillTimer 0&, hTimer: hTimer = 0  ' Timer löschen
  On Error Resume Next
  WSh.Shapes.Range("ToolTip").Delete                    ' Evtl. vorhandene Textbox löschen
End Sub


' #### In das Tabellenmodul ####
Private Sub CheckBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Call Tooltip_Create(CheckBox1, X, Y)
End Sub

Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  Call Tooltip_Create(CommandButton1, X, Y)
End Sub

Private Sub Worksheet_Deactivate()
  Call ToolTip_Delete(ActiveSheet)
End Sub

_________
viele Grüße
Karl-Heinz