Option Explicit
Private Const WM_USER = &H400
Private Const GW_CHILD As Long = 5
Private Const TTS_BALLOON = &H40
Private Const WS_POPUP As Long = &H80000000
Private Const TTS_ALWAYSTIP As Long = &H1
Private Const TTS_NOPREFIX = 2
Private Const TTF_TRANSPARENT As Long = &H100
Private Const TTF_SUBCLASS As Long = &H10
Private Const TTM_SETDELAYTIME = WM_USER + 3
Private Const TTM_SETTITLEW = WM_USER + 33 ' Private Const TTM_SETTITLEA = WM_USER + 32 - A --> chuoi ANSI
Private Const ICC_BAR_CLASSES = &H4
Private Const TTM_ADDTOOLW = WM_USER + 50 ' Private Const TTM_ADDTOOLA = WM_USER + 4
Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
Private Const TTM_SETTIPBKCOLOR = WM_USER + 19
Private Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
Private Const TTM_TRACKPOSITION = WM_USER + 18
Private Const TOOLTIPS_CLASS = "tooltips_class32"
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTS_PER_INCH As Long = 72
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
#If VBA7 Then
Private Declare PtrSafe Function GetFocus Lib "user32" () As LongPtr
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByRef lParam As Any) As LongPtr
Private Declare PtrSafe 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 LongPtr, _
ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Const TTDT_INITIAL As LongPtr = 3
Private Type tagTOOLINFOW
cbSize As Long
uFlags As Long
hwnd As LongPtr
uId As Long
rc As RECT
hInst As Long
lpszText As String
lParam As Long
End Type
Dim ToolTipsHandle As LongPtr
Dim hForm As LongPtr, hClientArea As LongPtr
#Else
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) 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, ByRef lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Const TTDT_INITIAL As Long = 3
Private Type tagTOOLINFOW
cbSize As Long
uFlags As Long
hwnd As Long
uId As Long
rc As RECT
hInst As Long
lpszText As String
lParam As Long
End Type
Dim ToolTipsHandle As Long
Dim hForm As Long, hClientArea As Long
#End If
Private ti As tagTOOLINFOW
Private PixelXPerPoint As Double, PixelYPerPoint As Double, count As Long
#If VBA7 Then
Sub CreateTipsWindow(form As Object, ByVal hIcon As LongPtr, ByVal Title As String)
#Else
Sub CreateTipsWindow(form As Object, ByVal hIcon As Long, ByVal Title As String)
#End If
#If VBA7 Then
Dim DC As LongPtr
' tao control ToolTip
ToolTipsHandle = CreateWindowEx(0, TOOLTIPS_CLASS, "", _
WS_POPUP Or TTS_NOPREFIX Or TTS_BALLOON Or TTS_ALWAYSTIP, _
0, 0, 0, 0, 0, 0, Application.HinstancePtr, ByVal 0)
#Else
Dim DC As Long
' tao control ToolTip
ToolTipsHandle = CreateWindowEx(0, TOOLTIPS_CLASS, "", _
WS_POPUP Or TTS_NOPREFIX Or TTS_BALLOON Or TTS_ALWAYSTIP, _
0, 0, 0, 0, 0, 0, Application.hInstance, ByVal 0)
#End If
' thiet lap icon va tieu de
SendMessage ToolTipsHandle, TTM_SETTITLEW, hIcon, ByVal StrPtr(Title)
' thiet lap do rong max cua tool = 200
SendMessage ToolTipsHandle, TTM_SETMAXTIPWIDTH, 0, ByVal 200
' thiet lap mau nen
SendMessage ToolTipsHandle, TTM_SETTIPBKCOLOR, RGB(200, 200, 255), ByVal 0
' thiet lap mau chu
SendMessage ToolTipsHandle, TTM_SETTIPTEXTCOLOR, RGB(0, 0, 255), ByVal 0
' thiet lap delay = 100 ms
SendMessage ToolTipsHandle, TTM_SETDELAYTIME, TTDT_INITIAL, ByVal 100
hForm = FindWindow("ThunderDFrame", form.Caption)
hClientArea = GetWindow(hForm, GW_CHILD)
DC = GetDC(0)
PixelXPerPoint = GetDeviceCaps(DC, LOGPIXELSX) / POINTS_PER_INCH
PixelYPerPoint = GetDeviceCaps(DC, LOGPIXELSY) / POINTS_PER_INCH
ReleaseDC 0, DC
count = 1
End Sub
Sub AddTool(ctl As MSForms.Control)
Dim DC As Long, k As Long, IsVisible As Boolean
#If VBA7 Then
Dim hChild As LongPtr
#Else
Dim hChild As Long
#End If
ti.cbSize = Len(ti)
ti.uFlags = TTF_TRANSPARENT Or TTF_SUBCLASS
ti.hwnd = 0
With ctl
If .Tag <> "" Then
If TypeName(ctl) = "ListBox" Or TypeName(ctl) = "Frame" Then
ctl.SetFocus
hChild = GetFocus
GetClientRect hChild, ti.rc
ti.hwnd = hChild
Else
If TypeName(ctl.Parent) = "Frame" Then
ctl.Parent.SetFocus
ti.hwnd = GetFocus
ElseIf TypeName(ctl.Parent) = "Page" Then
If ctl.Parent.index = ctl.Parent.Parent.Value Then
ctl.Parent.Parent.SetFocus
ti.hwnd = GetFocus
End If
ElseIf TypeOf ctl.Parent Is MSForms.UserForm Then
ti.hwnd = hClientArea
End If
' xac dinh vung hinh chu nhat cho tool
ti.rc.Left = .Left * PixelXPerPoint
ti.rc.Top = .Top * PixelYPerPoint
ti.rc.Right = (.Left + .Width) * PixelXPerPoint
ti.rc.Bottom = (.Top + .Height) * PixelYPerPoint
End If
ti.uId = count
' text tooltop
ti.lpszText = StrConv(.Tag, vbUnicode)
' them tool
If ti.hwnd <> 0 Then
SendMessage ToolTipsHandle, TTM_ADDTOOLW, 0, ti
count = count + 1
End If
End If
End With
End Sub
Sub DestroyToolTip()
' huy cua so
DestroyWindow ToolTipsHandle
End Sub
