1 ''' // *****************************************************************************
   2 ''' // Tooltips
   3 ''' // Ver.: 1.0.0
   4 ''' // Author: 10Tec Company
   5 
   6 ''' // Another great piece of code posted in the Internet ... saved braining ...
   7 ''' // Using the API we will define our own ToolTips for ListView entries, incl. LineBreaks and other goodies.
   8 
   9 ''' // Ver.: 1.0.1; 21.07.2009; UG - (c) digital-ecom GmbH
  10 ''' // Adapted for MS Excel (VBA) and especially MS Excel 2000.
  11 ''' // *****************************************************************************
  12 
  13 Private Declare Function CreateWindowEx Lib "user32" _
  14         Alias "CreateWindowExA" (ByVal dwExStyle As Long, _
  15         ByVal lpClassName As String, ByVal lpWindowName As String, _
  16         ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, _
  17         ByVal nWidth As Long, ByVal nHeight As Long, _
  18         ByVal hWndParent As Long, ByVal hMenu As Long, _
  19         ByVal hInstance As Long, lpParam As Any) As Long
  20 Private Declare Function SendMessage Lib "user32" _
  21         Alias "SendMessageA" (ByVal hwnd As Long, _
  22         ByVal wMsg As Long, ByVal wParam As Long, _
  23         lParam As Any) As Long
  24 Private Declare Function SendMessageLong Lib "user32" _
  25         Alias "SendMessageA" (ByVal hwnd As Long, _
  26         ByVal wMsg As Long, ByVal wParam As Long, _
  27         ByVal lParam As Long) As Long
  28 Private Declare Function DestroyWindow Lib "user32" _
  29         (ByVal hwnd As Long) As Long
  30 
  31 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  32         (ByVal lpClassName As String, _
  33         ByVal lpWindowName As String) As Long
  34 
  35 ''Windows API Constants
  36 Private Const WM_USER = &H400
  37 Private Const CW_USEDEFAULT = &H80000000
  38 
  39 ''Windows API Types
  40 Private Type RECT
  41         Left As Long
  42         Top As Long
  43         Right As Long
  44         Bottom As Long
  45 End Type
  46 
  47 ''Tooltip Window Constants
  48 Private Const TTS_NOPREFIX = &H2
  49 Private Const TTF_TRANSPARENT = &H100
  50 Private Const TTF_CENTERTIP = &H2
  51 Private Const TTM_ADDTOOLA = (WM_USER + 4)
  52 Private Const TTM_ACTIVATE = WM_USER + 1
  53 Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12)
  54 Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
  55 Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
  56 Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
  57 Private Const TTM_SETTITLE = (WM_USER + 32)
  58 Private Const TTS_BALLOON = &H40
  59 Private Const TTS_ALWAYSTIP = &H1
  60 Private Const TTF_SUBCLASS = &H10
  61 Private Const TTF_IDISHWND = &H1
  62 Private Const TTM_SETDELAYTIME = (WM_USER + 3)
  63 Private Const TTDT_AUTOPOP = 2
  64 Private Const TTDT_INITIAL = 3
  65 
  66 Private Const TOOLTIPS_CLASSA = "tooltips_class32"
  67 
  68 ''Tooltip Window Types
  69 Private Type TOOLINFO
  70     lSize As Long
  71     lFlags As Long
  72     hwnd As Long
  73     lId As Long
  74     lpRect As RECT
  75     hInstance As Long
  76     lpStr As String
  77     lParam As Long
  78 End Type
  79 
  80 
  81 Public Enum ttIconType
  82     TTNoIcon = 0
  83     TTIconInfo = 1
  84     TTIconWarning = 2
  85     TTIconError = 3
  86 End Enum
  87 
  88 Public Enum ttStyleEnum
  89     TTStandard
  90     TTBalloon
  91 End Enum
  92 
  93 'local variable(s) to hold property value(s)
  94 Private mvarBackColor As Long
  95 Private mvarTitle As String
  96 Private mvarForeColor As Long
  97 Private mvarIcon As ttIconType
  98 Private mvarCentered As Boolean
  99 Private mvarStyle As ttStyleEnum
 100 Private mvarTipText As String
 101 Private mvarVisibleTime As Long
 102 Private mvarDelayTime As Long
 103 
 104 'private data
 105 Private m_lTTHwnd As Long        ' hwnd of the tooltip
 106 Private m_lParentHwnd As Long    ' hwnd of the window the tooltip attached to
 107 
 108 Private ti As TOOLINFO
 109 
 110 
 111 ''' // Initialize Class
 112 ''' // Adjust timings according to your needs
 113 Private Sub Class_Initialize()
 114    mvarDelayTime = 100
 115    mvarVisibleTime = 12000
 116 End Sub
 117 
 118 Private Sub Class_Terminate()
 119    Destroy
 120 End Sub
 121 
 122 ''' // Create the Tooltip Window
 123 Public Function Create(ByVal ParentHwnd As Long) As Boolean
 124 Dim lWinStyle As Long
 125 Dim appHWnd As Long
 126 
 127    If m_lTTHwnd <> 0 Then
 128       DestroyWindow m_lTTHwnd
 129    End If
 130 
 131    m_lParentHwnd = ParentHwnd
 132 
 133    lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
 134 
 135    ''create baloon style if desired
 136    If mvarStyle = TTBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON
 137 
 138     ''' // If Excel Ver. < Excel 2002 use a different approach for getting handle to Application; we simply use the general Application handle instead of an instance handle.
 139     ''' // This was tested to work out correctly in case 2 instances of Excel are running ...
 140     If Val(Application.Version) < 10 Then
 141         appHWnd = FindWindow("XLMAIN", vbNullString)
 142     Else
 143         appHWnd = Application.hInstance
 144     End If
 145 
 146    m_lTTHwnd = CreateWindowEx(0&, _
 147                               TOOLTIPS_CLASSA, _
 148                               vbNullString, _
 149                               lWinStyle, _
 150                               CW_USEDEFAULT, _
 151                               CW_USEDEFAULT, _
 152                               CW_USEDEFAULT, _
 153                               CW_USEDEFAULT, _
 154                               0&, _
 155                               0&, _
 156                               appHWnd, _
 157                               0&)
 158 
 159    ''now set our tooltip info structure
 160    With ti
 161       ''if we want it centered, then set that flag
 162       If mvarCentered Then
 163          .lFlags = TTF_SUBCLASS Or TTF_CENTERTIP Or TTF_IDISHWND
 164       Else
 165          .lFlags = TTF_SUBCLASS Or TTF_IDISHWND
 166       End If
 167 
 168       ''set the hwnd prop to our parent control's hwnd
 169       .hwnd = m_lParentHwnd
 170       .lId = m_lParentHwnd       '0
 171       .hInstance = appHWnd 'Application.hInstance
 172       '.lpstr    = ALREADY SET
 173       '.lpRect   = lpRect
 174       .lSize = Len(ti)
 175    End With
 176 
 177    ''add the tooltip structure
 178    SendMessage m_lTTHwnd, TTM_ADDTOOLA, 0&, ti
 179 
 180    ''if we want a title or we want an icon
 181    If mvarTitle <> vbNullString Or mvarIcon <> TTNoIcon Then
 182       SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), _
 183                   ByVal mvarTitle
 184    End If
 185 
 186    If mvarForeColor <> Empty Then
 187       SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
 188    End If
 189 
 190    If mvarBackColor <> Empty Then
 191       SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
 192    End If
 193 
 194    SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, _
 195                               mvarVisibleTime
 196    SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, _
 197                               mvarDelayTime
 198 
 199 End Function
 200 
 201 Public Sub Destroy()
 202    If m_lTTHwnd <> 0 Then
 203       DestroyWindow m_lTTHwnd
 204    End If
 205 End Sub
 206 
 207 ''' // All Tooltip Properties:
 208 Public Property Let Style(ByVal vData As ttStyleEnum)
 209    'used when assigning a value to the property, on the left side
 210    'of an assignment.
 211    'Syntax: X.Style = 5
 212    mvarStyle = vData
 213 End Property
 214 
 215 Public Property Get Style() As ttStyleEnum
 216    'used when retrieving value of a property, on the right side
 217    'of an assignment.
 218    'Syntax: Debug.Print X.Style
 219    Style = mvarStyle
 220 End Property
 221 
 222 Public Property Let Centered(ByVal vData As Boolean)
 223    'used when assigning a value to the property, on the left side
 224    'of an assignment.
 225    'Syntax: X.Centered = 5
 226    mvarCentered = vData
 227 End Property
 228 
 229 Public Property Get Centered() As Boolean
 230    'used when retrieving value of a property, on the right side
 231    'of an assignment.
 232    'Syntax: Debug.Print X.Centered
 233    Centered = mvarCentered
 234 End Property
 235 
 236 Public Property Let Icon(ByVal vData As ttIconType)
 237    mvarIcon = vData
 238    If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> _
 239       TTNoIcon Then
 240       SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), _
 241       ByVal mvarTitle
 242    End If
 243 End Property
 244 
 245 Public Property Get Icon() As ttIconType
 246    Icon = mvarIcon
 247 End Property
 248 
 249 Public Property Let ForeColor(ByVal vData As Long)
 250    mvarForeColor = vData
 251    If m_lTTHwnd <> 0 Then
 252       SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0&
 253    End If
 254 End Property
 255 
 256 Public Property Get ForeColor() As Long
 257    ForeColor = mvarForeColor
 258 End Property
 259 
 260 Public Property Let Title(ByVal vData As String)
 261    mvarTitle = vData
 262    If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then
 263       SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle
 264    End If
 265 End Property
 266 
 267 Public Property Get Title() As String
 268    Title = ti.lpStr
 269 End Property
 270 
 271 Public Property Let BackColor(ByVal vData As Long)
 272    mvarBackColor = vData
 273    If m_lTTHwnd <> 0 Then
 274       SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0&
 275    End If
 276 End Property
 277 
 278 Public Property Get BackColor() As Long
 279    BackColor = mvarBackColor
 280 End Property
 281 
 282 Public Property Let TipText(ByVal vData As String)
 283    mvarTipText = vData
 284    ti.lpStr = vData
 285    If m_lTTHwnd <> 0 Then
 286       SendMessage m_lTTHwnd, TTM_UPDATETIPTEXTA, 0&, ti
 287    End If
 288 End Property
 289 
 290 Public Property Get TipText() As String
 291    TipText = mvarTipText
 292 End Property
 293 
 294 Public Property Get VisibleTime() As Long
 295    VisibleTime = mvarVisibleTime
 296 End Property
 297 
 298 Public Property Let VisibleTime(ByVal lData As Long)
 299    mvarVisibleTime = lData
 300 End Property
 301 
 302 Public Property Get DelayTime() As Long
 303    DelayTime = mvarDelayTime
 304 End Property
 305 
 306 Public Property Let DelayTime(ByVal lData As Long)
 307    mvarDelayTime = lData
 308 End Property
 309 
 310