vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
vb@rchiv Offline-Reader - exklusiv auf der vb@rchiv CD Vol.4  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik:    |   VB-Versionen: VB5, VB601.11.05
Moderne ToolTips beliebig positionieren und dauerhaft anzeigen

Mit dieser ToolTip-Klasse lassen sich moderne ToolTips gezielt ein- und ausblenden, und das sogar an jeder beliebigen Position auf dem Bildschirm.

Autor:  LonelySuicide666Bewertung:     [ Jetzt bewerten ]Views:  1.912 
http://www.vbapihelpline.de/System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 Beispielprojekt 

Normalerweise werden ToolTips immer nur dann angezeigt, wenn der Mauszeiger über ein Control bewegt wird und dann kurz "ruht". Nach einer bestimmten Zeit wird der ToolTip dann autom. wieder ausgeblendet.

In manchen Situationen könnte es aber durchaus sinnvoll sein, einen modernen ToolTip als "Hinweistext" für den Anwender gezielt an einer bestimmten Position im Formular anzuzeigen - und das sogar dauerhaft, egal wie und wohin die Maus bewegt wird.

Nachfolgendes Klassenmodul erledigt exakt diese Aufgabe für uns. Per "ShowTip"-Aufruf wird der ToolTip im modernen Design angezeigt. Per "CloseTip"-Aufruf lässt sich der ToolTip gezielt wieder ausblenden.

Das Klassenmodul ToolTip

Option Explicit
 
' Benötigte API-Deklarationen
Private Declare Function CreateWindowEx Lib "user32.dll" _
  Alias "CreateWindowExA" ( _
  ByVal dwExStyle As Long, _
  ByVal lpClassName As String, _
  ByVal lpWindowName As String, _
  ByVal dwStyle As Long, _
  ByVal x As Long, _
  ByVal y As Long, _
  ByVal nWidth As Long, _
  ByVal nHeight As Long, _
  ByVal hWndParent As Long, _
  ByVal hMenu As Long, _
  ByVal hInstance As Long, _
  lpParam As Any) As Long
 
Private Declare Function DestroyWindow Lib "user32.dll" ( _
  ByVal hwnd As Long) As Long
 
Private Declare Function INITCOMMONCONTROLSEX Lib "comctl32.dll" _
  Alias "InitCommonControlsEx" ( _
  ByRef tlpICEX As ICEX) As Long
 
Private Declare Function SetWindowPos Lib "user32" ( _
  ByVal hwnd As Long, _
  ByVal hWndInsertAfter As Long, _
  ByVal x As Long, _
  ByVal y As Long, _
  ByVal cx As Long, _
  ByVal cy As Long, _
  ByVal wFlags As Long) As Long
 
Private Declare Function SendMessage Lib "user32" _
  Alias "SendMessageA" ( _
  ByVal hwnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  lParam As Any) As Long
 
Private Declare Function SetWindowLong Lib "user32" _
  Alias "SetWindowLongA" ( _
  ByVal hwnd As Long, _
  ByVal nIndex As Long, _
  ByVal dwNewLong As Long) As Long
 
Private Declare Function GetWindowLong Lib "user32" _
  Alias "GetWindowLongA" ( _
  ByVal hwnd As Long, _
  ByVal nIndex As Long) As Long
 
Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  pDest As Any, _
  pSrc As Any, _
  ByVal ByteLen As Long)
 
Private Declare Function GetCursorPos Lib "user32" ( _
  lpPoint As POINTAPI) As Long
 
Private Declare Function ClientToScreen Lib "user32" ( _
  ByVal hwnd As Long, _
  lpPoint As POINTAPI) As Long
 
Private Type POINTAPI
  x As Long
  y As Long
End Type
 
Private Type ICEX
  dwSize As Long
  dwICC As Long
End Type
 
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
 
Private Type TOOLINFO
  cbSize As Long
  uFlags As Long
  hwnd As Long
  uId As Long
  pRect As RECT
  hinst As Long
  lpszText As String
  lParam As Long
End Type
 
Private Const ICC_WIN95_CLASSES As Long = &HFF
Private Const TOOLTIPS_CLASSA As String = "tooltips_class32"
Private Const WM_USER As Long = &H400
Private Const WM_MOUSEMOVE As Long = &H200
Private Const CW_USEDEFAULT As Long = &H80000000
 
Private Const HWND_TOPMOST As Long = -1
 
Private Const WS_EX_TOPMOST As Long = &H8&
Private Const WS_POPUP As Long = &H80000000
 
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_STYLE = (-16)
 
Private Const SWP_NOACTIVATE As Long = &H10
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
 
Public Enum TTIcons
  TTI_ERROR = 3
  TTI_INFO = 1
  TTI_NONE = 0
  TTI_WARNING = 2
End Enum
 
Private Const TTDT_AUTOMATIC = 0
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
Private Const TTDT_RESHOW = 1
 
Private Const TTM_ACTIVATE As Long = (WM_USER + 1)
Private Const TTM_ADDTOOL As Long = (WM_USER + 4)
Private Const TTM_ADJUSTRECT As Long = (WM_USER + 31)
Private Const TTM_DELTOOL As Long = (WM_USER + 5)
Private Const TTM_ENUMTOOLS As Long = (WM_USER + 14)
Private Const TTM_GETBUBBLESIZE As Long = (WM_USER + 30)
Private Const TTM_GETCURRENTTOOL As Long = (WM_USER + 15)
Private Const TTM_GETDELAYTIME As Long = (WM_USER + 21)
Private Const TTM_GETMARGIN As Long = (WM_USER + 27)
Private Const TTM_GETMAXTIPWIDTH As Long = (WM_USER + 25)
Private Const TTM_GETTEXTA As Long = (WM_USER + 11)
Private Const TTM_GETTEXTW As Long = (WM_USER + 56)
Private Const TTM_GETTIPBKCOLOR As Long = (WM_USER + 22)
Private Const TTM_GETTIPTEXTCOLOR As Long = (WM_USER + 23)
Private Const TTM_GETTOOLCOUNT As Long = (WM_USER + 13)
Private Const TTM_GETTOOLINFOA As Long = (WM_USER + 8)
Private Const TTM_GETTOOLINFOW As Long = (WM_USER + 53)
Private Const TTM_HITTESTA As Long = (WM_USER + 10)
Private Const TTM_HITTESTW As Long = (WM_USER + 55)
Private Const TTM_NEWTOOLRECT As Long = (WM_USER + 6)
Private Const TTM_POP As Long = (WM_USER + 28)
Private Const TTM_POPUP As Long = (WM_USER + 34)
Private Const TTM_RELAYEVENT As Long = (WM_USER + 7)
Private Const TTM_SETDELAYTIME As Long = (WM_USER + 3)
Private Const TTM_SETMARGIN As Long = (WM_USER + 26)
Private Const TTM_SETMAXTIPWIDTH As Long = (WM_USER + 24)
Private Const TTM_SETTIPBKCOLOR As Long = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR As Long = (WM_USER + 20)
Private Const TTM_SETTITLE As Long = (WM_USER + 32)
Private Const TTM_SETTOOLINFO As Long = (WM_USER + 9)
Private Const TTM_TRACKACTIVATE As Long = (WM_USER + 17)
Private Const TTM_TRACKPOSITION As Long = (WM_USER + 18)
Private Const TTM_UPDATE As Long = (WM_USER + 29)
Private Const TTM_UPDATETIPTEXT  As Long = (WM_USER + 12)
Private Const TTM_WINDOWFROMPOINT As Long = (WM_USER + 16)
 
Private Const TTN_FIRST As Long = -520
Private Const TTN_GETDISPINFOA As Long = (TTN_FIRST - 0)
Private Const TTN_GETDISPINFOW As Long = (TTN_FIRST - 10)
Private Const TTN_LAST As Long = -549
Private Const TTN_LINKCLICK As Long = (TTN_FIRST - 3)
Private Const TTN_NEEDTEXTA As Long = TTN_GETDISPINFOA
Private Const TTN_NEEDTEXTW As Long = TTN_GETDISPINFOW
Private Const TTN_POP As Long = (TTN_FIRST - 2)
Private Const TTN_SHOW As Long = (TTN_FIRST - 1)
 
Private Const TTS_ALWAYSTIP As Long = &H1
Private Const TTS_BALLOON As Long = &H40
Private Const TTS_NOANIMATE As Long = &H10
Private Const TTS_NOFADE As Long = &H20
Private Const TTS_NOPREFIX As Long = &H2
 
Private Const TTF_SUBCLASS = &H10
Private Const TTF_IDISHWND = &H1
Private Const TTF_CENTERTIP = &H2
Private Const TTF_TRACK = &H20
Private Const TTF_TRANSPARENT = &H100
Private Const TTF_ABSOLUTE As Long = &H80
 
Private hwnd As Long
Private TI As TOOLINFO
Private TTText As String
Private TTTitle As String
Private TTIcon As TTIcons
' ToolTip-Klasse initialisieren
Private Sub Class_Initialize()
  Dim IC As ICEX
 
  With IC
    .dwSize = Len(IC)
    .dwICC = ICC_WIN95_CLASSES
  End With
  Call INITCOMMONCONTROLSEX(IC)
 
  hwnd = CreateWindowEx(WS_EX_TOPMOST, TOOLTIPS_CLASSA, "", _
    WS_POPUP Or TTS_NOPREFIX Or TTS_ALWAYSTIP Or TTF_TRANSPARENT, _
    CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
    0&, 0&, App.hInstance, ByVal 0&)
 
  Call SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, _
    SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE)
End Sub
' ToolTip ausblenden und zerstören
Private Sub Class_Terminate()
  If TI.hwnd <> 0 Then
    CloseTip
    SendMessage hwnd, TTM_DELTOOL, 0&, TI
  End If
  Call DestroyWindow(hwnd)
End Sub
' ToolTip-Text festlegen
Public Property Get ToolTipText() As String
  ToolTipText = TTText
End Property
 
Public Property Let ToolTipText(ByVal NewText As String)
  TTText = NewText
  Call SendMessage(hwnd, TTM_UPDATETIPTEXT, 0&, TI)
End Property
' ToolTip-Title festlegen
Public Property Get ToolTipTitle() As String
  ToolTipTitle = TTTitle
End Property
 
Public Property Let ToolTipTitle(ByVal NewTitle As String)
  TTTitle = NewTitle
  If TTTitle <> "" Then
    Call SendMessage(hwnd, TTM_SETTITLE, TTIcon, ByVal TTTitle)
  Else
    Call SendMessage(hwnd, TTM_SETTITLE, TTIcon, 0&)
  End If
End Property
' ToolTip-Icon festlegen
Public Property Get ToolTipIcon() As TTIcons
  ToolTipIcon = TTIcon
End Property
 
Public Property Let ToolTipIcon(ByVal NewIcon As TTIcons)
  TTIcon = NewIcon
  If TTTitle <> "" Then
    Call SendMessage(hwnd, TTM_SETTITLE, TTIcon, ByVal TTTitle)
  Else
    Call SendMessage(hwnd, TTM_SETTITLE, TTIcon, 0&)
  End If
End Property
' Moderner Balloon-Toip?
Public Property Get BalloonTip() As Boolean
  Dim TmpStyle
 
  TmpStyle = GetWindowLong(hwnd, GWL_STYLE)
  BalloonTip = CBool(TmpStyle And TTS_BALLOON)
End Property
 
Public Property Let BalloonTip(ByVal ShowBallon As Boolean)
  If ShowBallon Then
    Call SetWindowLong(hwnd, GWL_STYLE, WS_POPUP Or TTS_NOPREFIX Or TTS_ALWAYSTIP Or TTS_BALLOON)
  Else
    Call SetWindowLong(hwnd, GWL_STYLE, WS_POPUP Or TTS_NOPREFIX Or TTS_ALWAYSTIP)
  End If
End Property
' ToolTip an bestimmter Position dauerhaft anzeigen
Public Function ShowTip(ByVal ParentWindow As Long, ByVal x As Long, ByVal y As Long)
  Dim TmpPoint As POINTAPI
 
  ' ggf. vorhandenen ToolTip ausblenden     
  If TI.hwnd <> 0 Then
    CloseTip
    SendMessage hwnd, TTM_DELTOOL, 0&, TI
  End If
 
  ' Koordinaten bezogen auf den Desktop umrechnen
  TmpPoint.x = x
  TmpPoint.y = y
  Call ClientToScreen(ParentWindow, TmpPoint)
 
  ' ToolTip-Info-Struktur füllen
  With TI
    .cbSize = Len(TI)
    .hinst = App.hInstance
    .hwnd = ParentWindow
    .lpszText = TTText & vbNullChar
    .uId = ParentWindow
    .uFlags = TTF_ABSOLUTE Or TTF_TRACK
  End With
 
  ' ToolTip anzeigen
  Call SendMessage(hwnd, TTM_ADDTOOL, 0&, TI)
  Call SendMessage(hwnd, TTM_SETDELAYTIME, TTDT_INITIAL, ByVal 1&)
  Call SendMessage(hwnd, TTM_TRACKPOSITION, 0, ByVal MakelParam(TmpPoint.y, TmpPoint.x))
  Call SendMessage(hwnd, TTM_TRACKACTIVATE, 1, TI)
End Function
' ToolTip ausblenden
Public Sub CloseTip()
  If TI.hwnd <> 0 Then
    Call SendMessage(hwnd, TTM_TRACKACTIVATE, 0, TI)
  End If
End Sub
' Hilfsfunktion
Private Function MakelParam(ByVal Hi As Integer, ByVal Lo As Integer) As Long
  Dim pInt(1) As Integer
 
  pInt(0) = Lo
  pInt(1) = Hi
  CopyMemory MakelParam, pInt(0), 4
End Function

Ein kleines Beispiel für die Anwendung:
Auf einem Formular befinden sich mehrere Eingabefelder und zwei Command-Buttons. Der Anwender soll per "Hinweistext" darauf hingewiesen werden, dass er die Einstellungen über den 1. CommandButton dauerhaft speichern kann. Hierzu wird beim 1. CommandButton ein dauerhafter ToolTip angezeigt.

Option Explicit
 
' Objekt für die ToolTip-Klasse
Dim oToolTip As ToolTip
Private Sub Form_Load()
  ' ToolTip-Objekt initialisieren
  Set oToolTip = New ToolTip
 
  With oToolTip
    .BalloonTip = True
    .ToolTipIcon = TTI_INFO
    .ToolTipTitle = "Hinweis"
    .ToolTipText = "Klicken Sie auf 'Übernehmen', um die " & vbCrLf & _
      "Einstellungen dauerhaft zu speichern"
  End With
End Sub
Private Sub Form_Activate()
  With Command1
    ' ToolTip beim 1. CommandButton dauerhaft anzeigen
    oToolTip.ShowTip .hWnd, 10, .Height / Screen.TwipsPerPixelY
  End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
  ' ToolTip ausblenden und Objekt zerstören
  oToolTip.CloseTip
  Set oToolTip = Nothing
End Sub