-
Notifications
You must be signed in to change notification settings - Fork 2
/
clsToolTip.cls
312 lines (237 loc) · 8.23 KB
/
clsToolTip.cls
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsToolTip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'
' Defaults:
' DelayInitial = 500 (1/2 sec)
' DelayAutoPopup = 5000 (5 secs)
' DelayReshow = 100 (1/10 sec)
' MaxTipWidth = 0
' all Margins = 0
Private mnlgHwndTT As Long
Private mnlgMaxTip As Long
Public Function Create(ByRef frm As Form) As Boolean
If (mnlgHwndTT = 0) Then
Call InitCommonControls
'
' The hwndParent param lets the tooltip window
' be owned by the specified form and be destroyed
' along with it. We'll cleanup in Class_Terminate anyway.
' No WS_EX_TOPMOST or TTS_ALWAYSTIP per Win95 UI rules.
'
mnlgHwndTT = CreateWindowEx(0, TOOLTIPS_CLASS, vbNullString, TTS_ALWAYSTIP, 0, 0, 0, 0, frm.hWnd, 0, App.hInstance, ByVal 0)
End If
Create = CBool(mnlgHwndTT)
End Function
Private Sub Class_Terminate()
If mnlgHwndTT > 0 Then Call DestroyWindow(mnlgHwndTT)
End Sub
Public Function AddTool(ByRef ctrl As Control, Optional ByVal strText As String) As Boolean
On Error Resume Next
Dim ti As TOOLINFO
If (mnlgHwndTT = 0) Then Exit Function
If (fGetToolInfo(ctrl.hWnd, ti) = False) Then
With ti
.cbSize = Len(ti)
'
' TTF_IDISHWND must be set to tell the tooltip
' control to retrieve the control's rect from
' it's hWnd specified in uId.
'
.uFlags = TTF_SUBCLASS Or TTF_IDISHWND
.hWnd = ctrl.Container.hWnd
.uId = ctrl.hWnd
If Len(strText) > 0 Then
.lpszText = strText
' Else
' .lpszText = "Tool" & ToolCount + 1
End If
'
' Maintain the maximun tip text
' length for fGetToolInfo.
'
mnlgMaxTip = fMax(mnlgMaxTip, Len(.lpszText) + 1)
End With
'
' Returns 1 on success, 0 on failure
'
AddTool = SendMessageT(mnlgHwndTT, TTM_ADDTOOL, 0, ti)
End If
End Function
Private Function fMax(ByVal lngParm1 As Long, ByVal lngParm2 As Long) As Long
'
' Returns the larger of the two values.
'
If lngParm1 > lngParm2 Then
fMax = lngParm1
Else
fMax = lngParm2
End If
End Function
Public Function RemoveTool(ByRef ctrl As Control) As Boolean
Dim ti As TOOLINFO
If (mnlgHwndTT = 0) Then Exit Function
If fGetToolInfo(ctrl.hWnd, ti) Then
Call SendMessageT(mnlgHwndTT, TTM_DELTOOL, 0, ti)
RemoveTool = True
End If
End Function
Public Property Get BackColor() As OLE_COLOR
If (mnlgHwndTT = 0) Then Exit Property
'
' OLE_COLOR is defined in stdole2.tlb
'
BackColor = SendMessageT(mnlgHwndTT, TTM_GETTIPBKCOLOR, 0, 0)
End Property
Public Property Let BackColor(clr As OLE_COLOR)
If (mnlgHwndTT = 0) Then Exit Property
Call SendMessageT(mnlgHwndTT, TTM_SETTIPBKCOLOR, clr, 0)
End Property
Public Property Get DelayTime(dwType As ttDelayTimeConstants) As Long
If (mnlgHwndTT = 0) Then Exit Property
DelayTime = SendMessageT(mnlgHwndTT, TTM_GETDELAYTIME, (dwType And ttDelayMask), 0&)
End Property
Public Property Let DelayTime(dwType As ttDelayTimeConstants, dwMilliSecs As Long)
If (mnlgHwndTT = 0) Then Exit Property
Call SendMessageT(mnlgHwndTT, TTM_SETDELAYTIME, (dwType And ttDelayMask), ByVal dwMilliSecs) ' no rtn val
End Property
Public Property Get ForeColor() As OLE_COLOR
If (mnlgHwndTT = 0) Then Exit Property
ForeColor = SendMessageT(mnlgHwndTT, TTM_SETTIPTEXTCOLOR, 0, 0)
End Property
Public Property Let ForeColor(clr As OLE_COLOR)
If (mnlgHwndTT = 0) Then Exit Property
Call SendMessageT(mnlgHwndTT, TTM_SETTIPTEXTCOLOR, clr, 0) ' no rtn val
End Property
Public Property Get hWnd() As Long
hWnd = mnlgHwndTT
End Property
Public Property Get Margin(dwType As ttMarginConstants) As Long
Dim rc As RECT
If (mnlgHwndTT = 0) Then Exit Property
Call SendMessageT(mnlgHwndTT, TTM_GETMARGIN, 0, rc)
Select Case dwType
Case ttMarginLeft
Margin = rc.Left
Case ttMarginTop
Margin = rc.Top
Case ttMarginRight
Margin = rc.Right
Case ttMarginBottom
Margin = rc.Bottom
End Select
End Property
Public Property Let Margin(dwType As ttMarginConstants, cPixels As Long)
Dim rc As RECT
If (mnlgHwndTT = 0) Then Exit Property
Call SendMessageT(mnlgHwndTT, TTM_GETMARGIN, 0, rc)
Select Case dwType
Case ttMarginLeft
rc.Left = cPixels
Case ttMarginTop
rc.Top = cPixels
Case ttMarginRight
rc.Right = cPixels
Case ttMarginBottom
rc.Bottom = cPixels
End Select
Call SendMessageT(mnlgHwndTT, TTM_SETMARGIN, 0, rc)
End Property
Public Property Get MaxTipWidth() As Long
'
' If MaxTipWidth is -1, there is no word wrapping and
' text control characters are printed and not
' evaluated (i.e. a vbCrLf shows up as "||")
'
If (mnlgHwndTT = 0) Then Exit Property
MaxTipWidth = fLowWord(SendMessageT(mnlgHwndTT, TTM_GETMAXTIPWIDTH, 0, 0))
End Property
Private Function fLowWord(ByVal lngValue As Long) As Integer
'
' Returns the low-order word from a 32-bit value.
'
Call MoveMemory(fLowWord, lngValue, 2)
End Function
Public Property Let MaxTipWidth(ByVal lngWidth As Long)
'
' If MaxTipWidth is -1, there is no word wrapping and
' text control characters are printed and not
' evaluated (i.e. a vbCrLf shows up as "||")
'
If mnlgHwndTT = 0 Then Exit Property
If lngWidth < 1 Then lngWidth = -1
Call SendMessageT(mnlgHwndTT, TTM_SETMAXTIPWIDTH, 0, lngWidth)
End Property
Public Property Get ToolCount() As Long
If (mnlgHwndTT = 0) Then Exit Property
ToolCount = SendMessageT(mnlgHwndTT, TTM_GETTOOLCOUNT, 0, 0)
End Property
Public Property Get ToolTipHandle() As Long
ToolTipHandle = mnlgHwndTT
End Property
Public Property Get ToolText(ByRef ctrl As Control) As String
Dim ti As TOOLINFO
If (mnlgHwndTT = 0) Then Exit Property
If fGetToolInfo(ctrl.hWnd, ti, True) Then
ToolText = fGetStrFromBuffer(ti.lpszText)
End If
End Property
Private Function fGetStrFromBuffer(ByVal strValue As String) As String
If InStr(strValue, vbNullChar) Then
fGetStrFromBuffer = Left$(strValue, InStr(strValue, vbNullChar) - 1)
Else
'
' If strValue had no null char, the Left$ function
' above would rtn a zero length string ("").
'
fGetStrFromBuffer = strValue
End If
End Function
Public Property Let ToolText(ByRef ctrl As Control, ByVal strText As String)
Dim ti As TOOLINFO
If (mnlgHwndTT = 0) Then Exit Property
If fGetToolInfo(ctrl.hWnd, ti) Then
ti.lpszText = strText
mnlgMaxTip = fMax(mnlgMaxTip, Len(strText) + 1)
'
' The tooltip won't appear for the control
' if lpszText is an empty string
'
Call SendMessageT(mnlgHwndTT, TTM_UPDATETIPTEXT, 0, ti)
End If
End Property
Private Function fIsWindow(ByRef ctrl As Control) As Boolean
On Error GoTo ErrorHandler
fIsWindow = CBool(ctrl.hWnd)
ErrorHandler:
End Function
Private Function fGetToolInfo(ByVal lnghwndTool As Long, ti As TOOLINFO, _
Optional fGetText As Boolean = False) As Boolean
Dim nItems As Long
Dim i As Integer
ti.cbSize = Len(ti)
If fGetText Then ti.lpszText = String$(mnlgMaxTip, 0)
nItems = ToolCount
For i = 0 To nItems - 1
'
' Returns 1 on success, 0 on failure.
'
If SendMessageT(mnlgHwndTT, TTM_ENUMTOOLS, (i), ti) Then
If (lnghwndTool = ti.uId) Then
fGetToolInfo = True
Exit Function
End If
End If
Next
End Function