ShowTip Command1.hWnd, "這只是彈出的一個訊息"

Option Explicit

Public Declare Sub InitCommonControls Lib "comctl32" ()
Public 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
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Public Declare Function DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long

Public Const WM_USER = &H400

'TooltipInfo Flags(還有很多，一般只需要這兩個函式就足夠了)
Public Const TTF_CENTERTIP = &H2 '居中
Public Const TTF_SUBCLASS = &H10 '初始

'ToolTip訊息(透過Sendmessage API進行呼叫)
Public Const TTM_ADDTOOLA = (WM_USER + 4) '新增Tooltip
Public Const TTM_SETMAXTIPWIDTH = (WM_USER + 24) '設定最大寬度
Public Const TTM_SETTIPBKCOLOR = (WM_USER + 19) '設定背景顏色
Public Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20) '設定文字顏色
Public Const TTM_SETTITLE = (WM_USER + 32) '設定標題
Public Const TTM_SETDELAYTIME = (WM_USER + 3) '設定Tooltip時間

Public Const TTDT_AUTOPOP = 2
Public Const TTDT_INITIAL = 3

'Tooltip引數
Public Const TTS_ALWAYSTIP = &H1 '永久
Public Const TTS_BALLOON = &H40 '氣球(如果不要則是普通矩形視窗)

'Tooltip圖示樣式
Public Const TTI_NONE = 0 '無圖示
Public Const TTI_INFO = 1 '資訊
Public Const TTI_WARNING = 2 '警告
Public Const TTI_ERROR = 3 '錯誤

'型別
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

'Tooltip型別，VB自帶的API瀏覽器沒有，我是從Commctl.h中提取出來的

Public Type TOOLINFO

cbSize As Long
uFlags As Long
hWnd As Long
uid As Long
RECT As RECT
hinst As Long
lpszText As String
lParam As Long

End Type

'以下是主要實現程式碼，本來想封裝在類中，可想到並不是所有人都看得懂，乾脆就放在模組中做成函式，
'這樣好理解點,由於實現各種各樣的ToolTip樣式很多，這裡我只寫出了平時經常用到的方法：

Public TiphWnd As Long 'ToolTip控制程式碼

Public Sub ShowTip(ByVal hWnd As Long, ByVal TipMessage As String)

Dim lpRect As RECT, lpToolInfo As TOOLINFO, TipMsg As String

'在建立tooltips_class32時必須呼叫初始化。（這裡我覺得必須注意，必然加上這個API，開始我沒有新增上時，
'在VBIDE環境中除錯的時候一切正常，可是編譯以後老是出現不了ToolTip，這裡我鬱悶了很久，最後到網上找了關於這方面的資料，
'才知道在建立ToolTip時必須呼叫Comctl32.dll中的InitCommonControl API函式進行初始化。鬱悶，到現在才除錯透過）
InitCommonControls

'返回視窗的控制程式碼並建立ToolTip視窗
TiphWnd = CreateWindowEx(0, "tooltips_class32", vbNullString, TTS_ALWAYSTIP Or TTS_BALLOON, 0, 0, 0, 0, 0, 0, 0, ByVal 0&)

'獲取視窗矩形
GetClientRect hWnd, lpRect

With lpToolInfo

.cbSize = Len(lpToolInfo) '大小
.uFlags = TTF_SUBCLASS 'Tooltip樣式
.hWnd = hWnd '控制程式碼
.hinst = App.hInstance '控制程式碼例項
.lpszText = TipMessage 'ToolTip文字
.uid = 0 'uid為空
.RECT = lpRect '視窗矩形

End With

SendMessage TiphWnd, TTM_ADDTOOLA, 0, lpToolInfo '新增Tooltip

'顏色可以自己設定（我用了vbBlue和vbWhite）
SendMessage TiphWnd, TTM_SETTIPTEXTCOLOR, vbBlue, ByVal 0& '前景（字型）顏色
SendMessage TiphWnd, TTM_SETTIPBKCOLOR, vbWhite, ByVal 0& '背景顏色
SendMessage TiphWnd, TTM_SETTITLE, TTI_WARNING, ByVal "彈出訊息了" '標題

'設定顯示時間
SendMessage TiphWnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, ByVal 5000& '設定ToolTip顯示時間
SendMessage TiphWnd, TTM_SETDELAYTIME, TTDT_INITIAL, ByVal 500& '設定顯示ToolTip時隔時間

End Sub

Public Sub DeWindow() '最後不用的時候別忘了銷燬視窗

DestroyWindow TiphWnd

End Sub

[@more@]