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: 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 |