这是一个产生气泡提示的类,鼠标悬停时,产生一个气泡提示,现在想把它改成这样的功能,只有在鼠标点击时才出现气泡!以Lable控件为例,望高手指教
'*************************************************************************
'**文 件 名:clsToolTip
'**说 明:
'**创 建 人:叶帆
'**日 期:2002年4月24
'**修 改 人:
'**日 期:
'**描 述:气泡提示帮助类(clsToolTip)
'**版 本:V1.0
'*************************************************************************''用例
'ToolTip(0).Create Text1, "帮助1"
'ToolTip(1).Create Text2, "帮助1" + Chr(10) + Chr(13) + "帮助2", "12"
'ToolTip(2).Create Picture1, "帮助1" + Chr(10) + Chr(13) + "帮助2", "叶帆制作"
'ToolTip(3).Create Command1, "帮助1" + Chr(10) + Chr(13) + "帮助2" + Chr(10) + Chr(13) + "帮助3", "123"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 + 4)
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
Public Enum TTStyleEnum
TTStandard
TTBalloon
End Enum
Private TTStyle As TTStyleEnum
Private hToolTipHwnd As Long
Private TI As TOOLINFO'*************************************************************************
'**函 数 名:Create
'**输 入:ByVal vDatas(Object) - 控件类名
'** :ByVal vText(String) - 内容
'** :Optional ByVal vTilte(String) - 标题
'**输 出:(Boolean) -
'**功能描述:
'**全局变量:
'**调用模块:
'**作 者:叶帆
'**日 期:2002年4月24日
'**修 改 人:
'**日 期:
'**版 本:V1.0
'*************************************************************************
Public Function Create(ByVal vDatas As Object, ByVal vText As String, Optional ByVal vTilte As String) As Boolean
On Error GoTo errexit
Dim lpRect As RECT
'确定tooltip对象
Set TTParentControl = vDatas
'设置tooltip标题
TTTitle = vTilte
SendMessage hToolTipHwnd, TTM_SETTITLE, 0, ByVal TTTitle '设置tooltip文本
TI.lpStr = vText
SendMessage hToolTipHwnd, TTM_UPDATETIPTEXTA, 0, TI DestroyWindow hToolTipHwnd '取消原窗口
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
Exit Function
errexit:
MsgBox Err.Description, , "ToolTip类"
End Function
'*************************************************************************
'**文 件 名:clsToolTip
'**说 明:
'**创 建 人:叶帆
'**日 期:2002年4月24
'**修 改 人:
'**日 期:
'**描 述:气泡提示帮助类(clsToolTip)
'**版 本:V1.0
'*************************************************************************''用例
'ToolTip(0).Create Text1, "帮助1"
'ToolTip(1).Create Text2, "帮助1" + Chr(10) + Chr(13) + "帮助2", "12"
'ToolTip(2).Create Picture1, "帮助1" + Chr(10) + Chr(13) + "帮助2", "叶帆制作"
'ToolTip(3).Create Command1, "帮助1" + Chr(10) + Chr(13) + "帮助2" + Chr(10) + Chr(13) + "帮助3", "123"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 + 4)
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
Public Enum TTStyleEnum
TTStandard
TTBalloon
End Enum
Private TTStyle As TTStyleEnum
Private hToolTipHwnd As Long
Private TI As TOOLINFO'*************************************************************************
'**函 数 名:Create
'**输 入:ByVal vDatas(Object) - 控件类名
'** :ByVal vText(String) - 内容
'** :Optional ByVal vTilte(String) - 标题
'**输 出:(Boolean) -
'**功能描述:
'**全局变量:
'**调用模块:
'**作 者:叶帆
'**日 期:2002年4月24日
'**修 改 人:
'**日 期:
'**版 本:V1.0
'*************************************************************************
Public Function Create(ByVal vDatas As Object, ByVal vText As String, Optional ByVal vTilte As String) As Boolean
On Error GoTo errexit
Dim lpRect As RECT
'确定tooltip对象
Set TTParentControl = vDatas
'设置tooltip标题
TTTitle = vTilte
SendMessage hToolTipHwnd, TTM_SETTITLE, 0, ByVal TTTitle '设置tooltip文本
TI.lpStr = vText
SendMessage hToolTipHwnd, TTM_UPDATETIPTEXTA, 0, TI DestroyWindow hToolTipHwnd '取消原窗口
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
Exit Function
errexit:
MsgBox Err.Description, , "ToolTip类"
End Function
Private Sub Form_Click()
Dim X As Class1
Set X = New Class1
y = X.Create(Form1, "OK")
End SubPrivate Sub Label1_Click()
Dim X As Class1
Set X = New Class1
y = X.Create(Label1, "OK")
End SubPrivate Sub Picture1_Click()
Dim X As Class1
Set X = New Class1
y = X.Create(Picture1, "OK")
End Sub
http://www.pscode.com/vb/scripts/ShowCode.asp?txtCodeId=47179&lngWId=1
要求单击Picture,出现提示。鼠标移出Picture后,提示消失。我一时看不明白那四个API,请高手指教。