窗体上的按钮，悬停提示，如何实现的

沉默的流星

   如图，当鼠标移动到窗体按钮上时，就会出现一个类似于，帮助或者是标注的一个提示：有框框和文字。
1：首先按钮里面的CONTROLTIPTEXT，是做不出如图所示的效果的。
2：我想过这肯定是利用了CommandButton1_MouseMove，但是如何显示那个框框（像excel中插入的自选图形），再加上提示文本（可以换行的）。我想过用没有边框的窗体，或者image控件，但是都无法做到那个带箭头的提示框
3：如果是表里的按钮，也许可以实现这个功能，因为表里可以用代码加入图形，但是窗体里，我不知道怎么加。
我甚至想过是不是用钩子函数或者API做的，因为我是初学者，那就不懂了。
      请各位老师提示，或者给个思路，这里谢谢了！

Moneky

设置控件的ControlTipText属性即可。

tuoying

这么好的问题怎么没人回答，我也想知道

tuoying

人家都说了，ControlTipText是做不出如图效果的

Moneky

tuoying 发表于 2012-4-19 20:37
人家都说了，ControlTipText是做不出如图效果的

确实没有看清楚。不好意思了

joforn

那个就是ToopTip，不过不是用的原有控件自带的，而是用API实现的，加黑的是标题，还可以带标。

jiulongpo

2003版的可以使用Assistant 对象
代表“Microsoft Office 助手”。
说明


使用 Assistant 属性返回 Assistant 对象。不存在 Assistant 对象的集合；任意时刻只能有一个 Assistant 对象是活动的。使用 Visible 属性显示该“助手”，并使用 On 属性启用该“助手”。缺省“助手”为“聪聪”（英文名为 Rocky）。若要通过编程选择其他“助手”，请使用 FileName 属性。


示例
下面的示例将显示“助手”及其动画效果。

Visual Basic for Applications
With Assistant
    .Visible = True
    .Animation = msoAnimationGreeting
End With

  注释
Microsoft Office system 2007 版中已减少对“Microsoft Office 助手”和“应答向导”的使用。

Moneky

修改了一个网上找的VB代码，使之适用于VBA，做了一个附件。可以实现大部分控件的提示。

1. '---------------说明    修改者:Excelhome-Moneky ------------------
   
2. '------------------------20120419---------------------------------
   
3. 
   
4. '类模块是网上前辈的VB代码，本人是在原来的代码基础上做了一点点修改，使之能够用于VBA，下面是修改说明
   
5. 
   
6. '1、原来的模块中没有Destroy方法——已添加
   
7. '2、VBA窗体控件的hwnd无法取得，即使用Getfcous得到的也只是窗口客户区的hwnd(或许),本例子中，一律使用客户区的hwnd，并把该句柄存入控件的tag属性中，
   
8. '   然后在本类中用clng函数转换成long
   
9. '3、在vb下可以方便取得控件的rect，在本例中是用客户区的rect与控件的top，left，width，height综合运算得出实际控件的rect（另外ListBox可以正常取得客户区rect，所以在类中特别处理了）
   
10. '   （其中坐标转换代码是直接引用的http://club.excelhome.net/forum.php?mod=viewthread&tid=203573，Excelhome——winland大侠的代码）
    
11. '4、Image与Label控件目前没有办法实现，但可能性还是有的。
    
12. '5、在创建提示的过程中，会转换焦点，因此请把Tab编号小的控件（默认控件）放在最后创建
    
13. 
    
14. 
    
15. '6、VBA调用范例,见窗体代码(下面为原样复制的窗体代码)
    
16. '------------VBA窗体代码,窗体上有两个commandbutton控件,name分别为:cmdOK,cmdNOOK------------
    
17. 'Private Declare Function GetFocus Lib "user32" () As Long
    
18. 'Dim myTip(1) As New cToolTip
    
19. 'Sub mySetTip(vObj As Object, vTip As cToolTip, strTitle As String, strTipText As String)       '这是一个自定义创建提示的过程参数分别为(控件,提示变量,标题,提示文本)
    
20. '    vObj.SetFocus                      '控件获取焦点——一些控件无法获取焦点，所以目前无法实现他们的冒泡提示
    
21. '    vObj.Tag = GetFocus                '将窗口客户区hwnd存入控件Tag
    
22. '    Set vTip.ParentControl = vObj      '控件绑定
    
23. '    vTip.ToolTipTitle = strTitle       '标题
    
24. '    vTip.ToolTipText = strTipText      '提示文字
    
25. '    vTip.Create                        '创建
    
26. 'End Sub
    
27. 'Private Sub UserForm_Initialize()
    
28. '    mySetTip Me.cmdOK, myTip(0), "气泡标题_cmdOK", "这是一个演示用的提示文字" & vbNewLine & "它还可以换行显示，这是第二行提示文字！"
    
29. '    mySetTip Me.cmdNoOk, myTip(1), "气泡标题_cmdNoOk", "这是一个演示用的提示文字" & vbNewLine & "它还可以换行显示，这是第二行提示文字！"
    
30. 'End Sub
    
31. 'Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    
32. '    myTip(0).Destroy
    
33. '    myTip(1).Destroy
    
34. 'End Sub
    
35. '--------------VBA窗体代码结束------
    
36. '--------------修改说明结束---------
    
37. 
    
38. 
    
39. 
    
40. 
    
41. 
    
42. 
    
43. 'clsTooptip
    
44. '使用范例：
    
45. 'Dim tooltip As New Class1
    
46. 'Set tooltip.ParentControl = Text1 '气泡应用于哪个控件(要有Hwnd)
    
47. 'tooltip.ToolTipTitle = "气泡标题" '气泡标题(不允许换行/字体粗体)
    
48. 'tooltip.ToolTipText = "气泡内容" & vbCrLf & "123" '气泡内容(允许换行)
    
49. 'tooltip.Create '创建气泡
    
50. 
    
51. Option Explicit
    
52. 
    
53. Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    
54. 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 '创建窗口
    
55. 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 '发出消息
    
56. Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    
57. Private Const WM_USER = &H400
    
58. Private Const CW_USEDEFAULT = &H80000000
    
59. 
    
60. Private Type RECT
    
61.     Left As Long
    
62.     Top As Long
    
63.     Right As Long
    
64.     Bottom As Long
    
65. End Type
    
66. 
    
67. Private Const TTS_NOPREFIX = &H2
    
68. Private Const TTF_TRANSPARENT = &H100
    
69. Private Const TTF_CENTERTIP = &H2
    
70. Private Const TTM_ADDTOOLA = (WM_USER + 4)
    
71. Private Const TTM_ACTIVATE = WM_USER + 1
    
72. Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
    
73. Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
    
74. Private Const TTM_SETTITLE = (WM_USER + 32)
    
75. Private Const TTS_BALLOON = &H40
    
76. Private Const TTF_SUBCLASS = &H10
    
77. Private Const TOOLTIPS_CLASSA = "tooltips_class32"
    
78. 
    
79. Private Type TOOLINFO
    
80.     lSize As Long
    
81.     lFlags As Long
    
82.     lHwnd As Long
    
83.     lId As Long
    
84.     lpRect As RECT
    
85.     hInstance As Long
    
86.     lpStr As String
    
87.     lParam As Long
    
88. End Type
    
89. 
    
90. Private TTTitle As String
    
91. Private TTParentControl As Object
    
92. Private TTStyle As TTStyleEnum
    
93. 
    
94. Public Enum TTStyleEnum
    
95.     TTStandard
    
96.     TTBalloon
    
97. End Enum
    
98. 
    
99. Private hToolTipHwnd As Long
    
100. Private TI As TOOLINFO
     
101. 
     
102. Public Function Create() As Boolean '创建气泡函数
     
103.     Dim lpRect As RECT
     
104. '    DestroyWindow hToolTipHwnd
     
105.     '建立tooltip窗口
     
106.     hToolTipHwnd = CreateWindowEx(0, TOOLTIPS_CLASSA, vbNullString, TTS_BALLOON, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CLng(TTParentControl.Tag), 0, Application.hInstance, 0)
     
107. '    Debug.Print TTParentControl.Name, TTParentControl.Tag, hToolTipHwnd
     
108.     '设置tooltip
     
109.     With TI
     
110.         .lFlags = TTF_SUBCLASS
     
111.         .lHwnd = CLng(TTParentControl.Tag)
     
112.         .lId = 0
     
113.         .hInstance = Application.hInstance
     
114.         .lpRect.Top = Point2PixelY(TTParentControl.Top)
     
115.         .lpRect.Left = Point2PixelX(TTParentControl.Left)
     
116.         .lpRect.Bottom = Point2PixelY(TTParentControl.Height) + .lpRect.Top
     
117.         .lpRect.Right = Point2PixelX(TTParentControl.Width) + .lpRect.Left
     
118. '        Debug.Print TypeName(TTParentControl)
     
119.         If TypeName(TTParentControl) = "ListBox" Then GetClientRect CLng(TTParentControl.Tag), .lpRect '特殊处理listbox
     
120.     End With
     
121.     SendMessage hToolTipHwnd, TTM_ADDTOOLA, 0, TI
     
122.     '给tooltip加上标题
     
123.     SendMessage hToolTipHwnd, TTM_SETTITLE, 0, ByVal TTTitle
     
124. End Function
     
125. 
     
126. Public Property Set ParentControl(ByVal vData As Object) '确定tooltip对象(要求有hwnd的控件)
     
127.     Set TTParentControl = vData
     
128. End Property
     
129. 
     
130. Public Property Let ToolTipTitle(ByVal vData As String) '设置tooltip的标题
     
131.     TTTitle = vData
     
132.     SendMessage hToolTipHwnd, TTM_SETTITLE, 0, ByVal TTTitle
     
133. End Property
     
134. 
     
135. Public Property Let ToolTipText(ByVal vData As String) '设置tooltip的文本(支持多行)
     
136.     TI.lpStr = vData
     
137.     SendMessage hToolTipHwnd, TTM_UPDATETIPTEXTA, 0, TI
     
138. End Property
     
139. Public Function Destroy() '销毁
     
140.     DestroyWindow hToolTipHwnd
     
141. End Function
     

复制代码

ToolTip.rar (22.88 KB, 下载次数: 1021)

2012-4-20 00:29 上传

点击文件名下载附件

liucqa

谢谢分享         

tuoying

Moneky 发表于 2012-4-20 00:29
修改了一个网上找的VB代码，使之适用于VBA，做了一个附件。可以实现大部分控件的提示。

非常棒！收藏了，很有价值的东西！谢谢你！