这是一个产生气泡提示的类,鼠标悬停时,产生一个气泡提示,现在想把它改成这样的功能,只有在鼠标点击时才出现气泡!以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

解决方案 »

  1.   

    '这个类要求对象具有hWnd属性,Label恐怕不行,Picture和Form可以,试一下下面代码,对比一下.
    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
      

  2.   

    在标签Label上显示气泡提示是可以的。看国外的这个网站:
    http://www.pscode.com/vb/scripts/ShowCode.asp?txtCodeId=47179&lngWId=1
      

  3.   

    你这个类在标签Label等没有句柄hWnd属性的控件上是不行的。
      

  4.   

    啊!我忽略了label没hwnd了,是我举例子举错了。该类我用过,很好用,鼠标悬停时就会出事气泡,不过我想达到另一效果,现以Picture为例。
    要求单击Picture,出现提示。鼠标移出Picture后,提示消失。我一时看不明白那四个API,请高手指教。
      

  5.   

    看看这个类:http://www.m5home.com/blog/article.asp?id=215如果是没有句柄的控件,那就直接在自己窗体(Me.hWnd)上显示气泡,但是利用座标参数显示到那个控件上去反正是个提示,在程序里是否属于目标控件并不影响吧:)