Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing modToolTipEx.bas (6.27 KB)
Attribute VB_Name = "modToolTipEx"
Option Explicit
Private hToolTip As Long
Private TT As TOOLINFO
Public Enum TTS_STYLES
TTS_ALWAYSTIP = &H1
TTS_BALLOON = &H40
TTS_NOANIMATE = &H10
TTS_NOFADE = &H20
TTS_NOPREFIX = &H2
End Enum
Public Enum TTF_FLAGS
TTF_ABSOLUTE = &H80
TTF_CENTERTIP = &H2
TTF_DI_SETITEM = &H8000
TTF_IDISHWND = &H1
TTF_RTLREADING = &H4
TTF_SUBCLASS = &H10
TTF_TRACK = &H20
TTF_TRANSPARENT = &H100
End Enum
Public Enum ICON_CONSTS
ICON_NONE = 0
ICON_INFO = 1
ICON_WARNING = 2
ICON_ERROR = 3
End Enum
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type TOOLINFO
lSize As Long
lFlags As Long
lHwnd As Long
lId As Long
lpRect As RECT
hInstance As Long
lpStr As String
lParam As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Const WM_USER = &H400
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTITLEA = (WM_USER + 32)
Private Const TTM_TRACKACTIVATE = (WM_USER + 17)
Private Const TTM_TRACKPOSITION = (WM_USER + 18)
Private Const TTM_UPDATE = (WM_USER + 29)
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const CW_USEDEFAULT = &H80000000
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOMOVE = &H2
Private Const HWND_TOPMOST = -1
Private Const TOOLTIP_CLASS = "tooltips_class32"
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function CreateWindowEx Lib "user32" 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" (ByVal hwnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function IsWindow Lib "user32" (ByVal hwnd 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 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
Public Function CreateToolTip(ByVal hWndParent As Long, ByVal ToolTipStyle As TTS_STYLES, ByVal ToolTipFlags As TTF_FLAGS, ByVal sToolTipText As String, ByVal sToolTipTitle As String, ByVal lIcon As ICON_CONSTS) As Long
Dim RCX As RECT
If CBool(IsWindow(hToolTip)) Then DestroyToolTip
hToolTip = CreateWindowEx(0&, TOOLTIP_CLASS, "", ToolTipStyle, _
CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
hWndParent, 0, App.hInstance, ByVal 0&)
CreateToolTip = hToolTip
SetWindowPos hToolTip, HWND_TOPMOST, 0&, 0&, 0&, 0&, _
SWP_NOACTIVATE Or SWP_NOSIZE Or SWP_NOMOVE
With TT
.lSize = Len(TT)
.lHwnd = hWndParent
.lId = 0
.hInstance = App.hInstance
.lpStr = sToolTipText
End With
GetClientRect hWndParent, RCX
TT.lpRect = RCX
TT.lFlags = ToolTipFlags
SendMessage hToolTip, TTM_ADDTOOLA, 0&, TT
SendMessage hToolTip, TTM_SETMAXTIPWIDTH, 0&, 0 ' Multi-line
SendMessage hToolTip, TTM_SETTITLEA, lIcon, ByVal sToolTipTitle
End Function
Public Sub ShowToolTip(ByVal bShowTip As Boolean)
If Not CBool(IsWindow(hToolTip)) Then Exit Sub
SendMessage hToolTip, TTM_TRACKACTIVATE, bShowTip, TT
End Sub
Public Sub MoveToolTip(ByVal X As Long, ByVal Y As Long, Optional ByVal hWndParent As Long)
Dim ScreenCoords As POINTAPI
If Not CBool(IsWindow(hToolTip)) Then Exit Sub
If Not IsMissing(hWndParent) Then
ScreenCoords.X = X
ScreenCoords.Y = Y
ClientToScreen hWndParent, ScreenCoords
X = ScreenCoords.X
Y = ScreenCoords.Y
End If
If TT.lFlags And TTF_ABSOLUTE Then
SendMessage hToolTip, TTM_TRACKPOSITION, 0&, ByVal MakeLong(X, Y)
Else
SetWindowPos hToolTip, HWND_TOPMOST, X, Y, 0, 0, SWP_NOACTIVATE Or SWP_NOSIZE
End If
End Sub
Public Sub UpdateToolTip(Optional ByVal sToolTipText As String, Optional ByVal sToolTipTitle As String, Optional ByVal lIcon As ICON_CONSTS)
If Not CBool(IsWindow(hToolTip)) Then Exit Sub
If Not IsMissing(sToolTipText) Then
TT.lpStr = sToolTipText
SendMessage hToolTip, TTM_UPDATETIPTEXTA, 0&, TT
End If
If Not IsMissing(sToolTipTitle) Then
SendMessage hToolTip, TTM_SETTITLEA, lIcon, ByVal sToolTipTitle
SendMessage hToolTip, TTM_UPDATE, 0, ByVal 0&
End If
End Sub
Public Function GetToolTipSize(Optional ByRef X As Long, Optional ByRef Y As Long, Optional ByRef CX As Long, Optional ByRef CY As Long) As Long
Dim RCX As RECT
If Not CBool(IsWindow(hToolTip)) Then Exit Function
GetToolTipSize = GetWindowRect(hToolTip, RCX)
If Not IsMissing(X) Then X = RCX.Left
If Not IsMissing(Y) Then Y = RCX.Top
If Not IsMissing(CX) Then CX = RCX.Right - RCX.Left
If Not IsMissing(CY) Then CY = RCX.Bottom - RCX.Top
End Function
Public Sub DestroyToolTip()
If CBool(IsWindow(hToolTip)) Then _
DestroyWindow hToolTip
If Not (frmMain.objCtrl Is Nothing) Then _
Set frmMain.objCtrl = Nothing
End Sub
Private Function MakeLong(ByVal lLow As Long, ByVal lHigh As Long) As Long
CopyMemory ByVal VarPtr(MakeLong), ByVal VarPtr(lLow), 2
CopyMemory ByVal VarPtr(MakeLong) + 2, ByVal VarPtr(lHigh), 2
End Function