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@]

来自 “ ITPUB博客 ” ，链接：http://blog.itpub.net/778857/viewspace-980393/，如需转载，请注明出处，否则将追究法律责任。

转载于:http://blog.itpub.net/778857/viewspace-980393/