VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ToolTip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) 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 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 GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Const WM_USER = &H400
Private Const CW_USEDEFAULT = &H80000000
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const TTS_NOPREFIX = &H2
Private Const TTF_TRANSPARENT = &H100
Private Const TTF_CENTERTIP = &H2
Private Const TTM_ADDTOOLA = (WM_USER + 4)
Private Const TTM_ACTIVATE = WM_USER + 1
Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTM_SETTITLE = (WM_USER + 32)
Private Const TTS_BALLOON = &H40
Private Const TTF_SUBCLASS = &H10
Private Const TOOLTIPS_CLASSA = "tooltips_class32"
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 TTTitle As String
Private TTParentControl As Object
Private TTStyle As TTStyleEnum
Public Enum TTStyleEnum
TTStandard
TTBalloon
End Enum
Private hToolTipHwnd As Long
Private TI As TOOLINFO
'創建函數
Public Function Create() As Boolean
Dim lpRect As RECT
DestroyWindow hToolTipHwnd
'建立tooltip窗口
hToolTipHwnd = CreateWindowEx(0, TOOLTIPS_CLASSA, vbNullString, TTS_BALLOON, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, TTParentControl.hwnd, 0, App.hInstance, 0)
GetClientRect TTParentControl.hwnd, lpRect
'設置tooltip
With TI
.lFlags = TTF_SUBCLASS
.lHwnd = TTParentControl.hwnd
.lId = 0
.hInstance = App.hInstance
.lpRect = lpRect
End With
SendMessage hToolTipHwnd, TTM_ADDTOOLA, 0, TI
'給tooltip加上標題
SendMessage hToolTipHwnd, TTM_SETTITLE, 0, ByVal TTTitle
End Function
'確定tooltip對象(要求有hwnd的控件)
Public Property Set ParentControl(ByVal vData As Object)
Set TTParentControl = vData
End Property
'設置tooltip的標題
Public Property Let ToolTipTitle(ByVal vData As String)
TTTitle = vData
SendMessage hToolTipHwnd, TTM_SETTITLE, 0, ByVal TTTitle
End Property
'設置tooltip的文本(支持多行)
Public Property Let ToolTipText(ByVal vData As String)
TI.lpStr = vData
SendMessage hToolTipHwnd, TTM_UPDATETIPTEXTA, 0, TI
End Property