Option Explicit
Private Declare Function GetDesktopWindow Lib "user32" () As Long
' Konstanten zum Erzeugen des ToolTip-Fensters
Private Const WS_POPUP = &H80000000
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_NOPREFIX = &H2
Private Const TTS_BALLOON = &H40
Private Const CW_USEDEFAULT = &H80000000
' Konstanten zum Ändern/Erstellen der ToolTips
Private Const WM_USER = &H400
Private Const TTM_SETDELAYTIME = WM_USER + 3
Private Const TTM_ADDTOOL = WM_USER + 4
Private Const TTM_SETTIPBKCOLOR = WM_USER + 19
Private Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
Private Const TTM_SETTITLE = WM_USER + 32
' Konstanten zum Setzen der Zeiten, nachdem der ToolTip
' erscheint bzw. wieder verschwindet
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
' Konstanten, welche über das Aussehen und das Verhalten
' des ToolTip-Fensters bestimmen
Private Const TTF_IDISHWND = &H1
Private Const TTF_CENTERTIP = &H2
Private Const TTF_SUBCLASS = &H10
' Konstanten zum Setzen der Schriftart des ToolTips
Private Const WM_SETFONT = &H30
Private Const LOGPIXELSY = 90
' Verschiedene Typdeklarationen für die API-Funktionen
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
cRect As RECT
hinst As Long
lpszText As String
End Type
' API-Funktionsdeklarationen
Private Declare Function CreateWindowEx Lib "user32.dll" _
Alias "CreateWindowExA" ( _
ByVal lExStyle As Long, _
ByVal strClassName As String, _
ByVal strWindowName As String, _
ByVal lStyle As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal lWidth As Long, _
ByVal lHeight As Long, _
ByVal hWndParent As Long, _
ByVal hMenu As Long, _
ByVal hInstance As Long, _
lParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32.dll" ( _
ByVal HWND As Long) As Long
Private Declare Function GetClientRect Lib "user32.dll" ( _
ByVal HWND As Long, _
lpRect As RECT) As Long
Private Declare Function SendMessage Lib "user32.dll" _
Alias "SendMessageA" ( _
ByVal HWND As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function SendMessageLong Lib "user32.dll" _
Alias "SendMessageA" ( _
ByVal HWND As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function SendMessageStr Lib "user32.dll" _
Alias "SendMessageA" ( _
ByVal HWND As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) As Long
Private Declare Function GetDC Lib "user32.dll" ( _
ByVal HWND As Long) As Long
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function CreateFont Lib "gdi32.dll" _
Alias "CreateFontA" ( _
ByVal lHeight As Long, _
ByVal lWidth As Long, _
ByVal lEscapement As Long, _
ByVal lOrientation As Long, _
ByVal lBold As Long, _
ByVal lItalic As Long, _
ByVal lUnderline As Long, _
ByVal lStrikethrough As Long, _
ByVal lCharset As Long, _
ByVal lOutputPrecision As Long, _
ByVal lClipPrecision As Long, _
ByVal lQuality As Long, _
ByVal lPitchAndFamily As Long, _
ByVal strFontName As String) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" ( _
ByVal hDC As Long, _
ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "kernel32.dll" ( _
ByVal lNumber As Long, _
ByVal lNumerator As Long, _
ByVal lDenominator As Long) As Long
' Membervariablen der Klasse
' Window-Handle des erzeugten ToolTip-Fensters
Private m_hWnd As Long
' Max. erlaubte Breite des ToolTip-Fensters
Private m_lMaxWidth As Long
' Aufzählung für das Icon im ToolTip
Public Enum enumIcon
NoIcon = 0
InfoIcon = 1
WarningIcon = 2
ErrorIcon = 3
End Enum
' Initialisierung
Private Sub Class_Initialize()
InitCommonControls
m_lMaxWidth = 300
End Sub
' Beenden
Private Sub Class_Terminate()
If m_hWnd <> 0 Then DestroyWindow m_hWnd
End Sub
' Setzen der maximalen Breite des ToolTip-Fensters in Pixel
Public Property Let MaxWidth(ByVal lMaxWidth As Long)
m_lMaxWidth = lMaxWidth
SendMessageLong m_hWnd, TTM_SETMAXTIPWIDTH, 0, _
m_lMaxWidth
End Property
' Setzen der Zeit in Millisekunden, wie lange der
' ToolTip angezeigt werden soll.
Public Property Let VisibleTime(ByVal lTime As Long)
If lTime > 32767 Then lTime = 32767
If lTime < 0 Then lTime = 0
SendMessageLong m_hWnd, TTM_SETDELAYTIME, _
TTDT_AUTOPOP, lTime
End Property
' Setzen der Zeit in Millisekunden, die vergeht, bis
' der ToolTip angezeigt werden soll.
Public Property Let DelayTime(ByVal lTime As Long)
If lTime > 32767 Then lTime = 32767
If lTime < 0 Then lTime = 0
SendMessageLong m_hWnd, TTM_SETDELAYTIME, _
TTDT_INITIAL, lTime
End Property
' Setzen der Text- und Rahmenfarbe für das ToolTip-
' Fenster.
Public Property Let ToolTipTextColor(ByVal lColor As Long)
SendMessageLong m_hWnd, TTM_SETTIPTEXTCOLOR, lColor, 0
End Property
' Hintergrundfarbe für das ToolTip-Fenster
Public Property Let ToolTipBackColor(ByVal lColor As Long)
SendMessageLong m_hWnd, TTM_SETTIPBKCOLOR, lColor, 0
End Property
' Schriftart für den Text im ToolTip festlegen
' Erwartet wird ein Standard Font-Objekt
Public Property Set Font(ByVal objFont As StdFont)
Dim hFont As Long
Dim lHeight As Long
Dim lItalic As Long
Dim lBold As Long
Dim lUnderline As Long
Dim lStrikethrough As Long
Dim lDefaultLocaleID As Long
Dim lRet As Long
Dim strCodePage As String * 6
Dim lCodePage As Long
If objFont Is Nothing Then Exit Property
' Um dem ToolTip-Fenster eine andere Schriftart
' unterzujubeln, gibt es leider keine Eigenschaft,
' die es ermöglicht, einfach so einen Schriftnamen
' oder eine Schriftgröße an das Window-Handle zu
' senden. Wir müssen dazu mit der API-Funktion
' CreateFont einen Font-Handle erzeugen und diesen
' mit Hilfe der Nachricht WM_SETFONT an das ToolTip-
' Fenster senden.
' Um mit der API-Funktion CreateFont einen korrekten
' Handle für einen Font zu erzeugen, muss die Größe
' des Fonts in Pixel auf dem Ausgabemedium
' umgerechnet werden. Dazu wird die untenstehende
' Formel verwendet, welche in der MSDN mehrfach zu
' finden ist.
lHeight = -MulDiv(objFont.Size, _
GetDeviceCaps(GetDC(m_hWnd), LOGPIXELSY), 72)
' Für die Funktion CreateFont müssen die
' Schriftattribute "Fett", "Kursiv", "Unterstrichen"
' und "Durchgestrichen" noch umdefiniert werden.
' Dabei kommt dem Attribut "Fett" eine besondere
' Bedeutung zu, da man hier sehr viele verschiedene
' Werte zwischen 100 und 900 angeben kann. Dabei
' entspricht ein Wert von 400 ungefähr dem
' Normaldruck und ein Wert von 700 entspricht etwa
' dem Fettdruck.
lItalic = IIf(objFont.Italic, 1&, 0&)
lBold = IIf(objFont.Bold, 700&, 400&)
lUnderline = IIf(objFont.Underline, 1&, 0&)
lStrikethrough = IIf(objFont.Strikethrough, 1&, 0&)
' Nun kann endlich die erforderliche Schrift mit der
' Funktion CreateFont erzeugt werden und mit
' SendMessageLong an das ToolTip-Fenster geschickt
' werden.
hFont = CreateFont(lHeight, 0&, 0&, 0&, lBold, _
lItalic, lUnderline, lStrikethrough, _
0&, 0&, 0&, 0&, 0&, objFont.Name)
lRet = SendMessageLong(m_hWnd, WM_SETFONT, hFont, 1&)
End Property
' Erzeugt das ToolTip-Fenster
Public Sub Create(ByVal hWndParent As Long, _
Optional ByVal bAlwaysTip As Boolean = True, _
Optional ByVal bBalloonTip As Boolean = True)
Dim nFlags As Long
Dim lPar As Long
lPar = GetDesktopWindow()
' Wir möchten kein normales Fenster :-)
nFlags = WS_POPUP Or TTS_NOPREFIX
' Falls der ToolTip auch bei deaktiviertem
' Control erscheinen soll...
If bAlwaysTip Then nFlags = nFlags Or TTS_ALWAYSTIP
' Falls ein "moderner" Balloon-ToolTip erwünscht...
If bBalloonTip Then nFlags = nFlags Or TTS_BALLOON
' Window-Handle erstellen
' m_hWnd = CreateWindowEx(0, "tooltips_class32", 0, _
nFlags, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
CW_USEDEFAULT, hWndParent, 0, App.hInstance, 0)
m_hWnd = CreateWindowEx(0, "tooltips_class32", 0, _
nFlags, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
CW_USEDEFAULT, lPar, 0, App.hInstance, 0)
' maximale Fensterbreite festlegen
SendMessageLong m_hWnd, TTM_SETMAXTIPWIDTH, 0, m_lMaxWidth
End Sub
' ToolTip zerstören
Public Sub Destroy()
DestroyWindow m_hWnd
End Sub
Public Sub AddControl(ByVal objControl As Object, _
ByVal strCaption As String, _
Optional ByVal bCenterToolTip As Boolean = False)
Dim udtToolInfo As TOOLINFO
With udtToolInfo
GetClientRect objControl.HWND, .cRect
.HWND = objControl.HWND
.uFlags = TTF_IDISHWND Or TTF_SUBCLASS
If bCenterToolTip Then
.uFlags = .uFlags Or TTF_CENTERTIP
End If
.uId = objControl.HWND
.lpszText = strCaption
.cbSize = Len(udtToolInfo)
End With
SendMessage m_hWnd, TTM_ADDTOOL, 0, udtToolInfo
End Sub
' ToolTip Icon und Titeltext festlegen
Public Sub SetToolTipTitle(ByVal strTitle As String, _
ByVal iTitleIcon As enumIcon)
SendMessageStr m_hWnd, TTM_SETTITLE, _
iTitleIcon, strTitle
End Sub