Option Explicit
' Declarations required for our subclassing
Public Const GWL_WNDPROC = (-4)
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) 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
' Positioning stuff
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const SWP_SHOWWINDOW = &H40
' Messages we are interested in
Private Const WM_MOUSEMOVE = &H200
Private Const WM_SHOWWINDOW = &H18
Private Const LB_ITEMFROMPOINT = &H1A9
Private Const LB_GETTEXT = &H189
Private Const LB_GETTEXTLEN = &H18A
Private Const LB_GETITEMRECT = &H198
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private lpOldProc As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public vbToolTip As PictureBox
Public Function WindowFunction(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lIndex As Long
Dim strTip As String
Dim lBuffLen As Long
Dim WindowRect As RECT
Dim myRect As RECT
' Is it a message we want to respond to?
Select Case iMsg
Case WM_MOUSEMOVE
lIndex = SendMessage(hwnd, LB_ITEMFROMPOINT, 0, ByVal lParam)
If Not (lIndex And &H10000) Then
lBuffLen = SendMessage(hwnd, LB_GETTEXTLEN, lIndex, 0)
If lBuffLen > 0 Then
strTip = Space(lBuffLen + 1)
SendMessage hwnd, LB_GETTEXT, lIndex, ByVal strTip
strTip = Left(strTip, lBuffLen)
GetWindowRect hwnd, WindowRect
SendMessage hwnd, LB_GETITEMRECT, lIndex, myRect
End If
If Form1.TextWidth(strTip) / Screen.TwipsPerPixelX + 2 > myRect.Right - myRect.Left Then
SetWindowPos vbToolTip.hwnd, HWND_TOPMOST, WindowRect.Left, myRect.Top + WindowRect.Top, Form1.TextWidth(strTip) / Screen.TwipsPerPixelX + 6, myRect.Bottom - myRect.Top + 3, SWP_SHOWWINDOW
vbToolTip.Cls
vbToolTip.CurrentX = 2 * Screen.TwipsPerPixelX
vbToolTip.Print strTip
Else
vbToolTip.Visible = False
End If
End If
Case WM_SHOWWINDOW
If wParam = False Then vbToolTip.Visible = False ' Closing list portion
Case Else
End Select
' Now do default stuff
WindowFunction = CallWindowProc(lpOldProc, hwnd, iMsg, wParam, lParam)
End Function
Sub Unhook(hwnd As Long)
If lpOldProc Then
Call SetWindowLong(hwnd, GWL_WNDPROC, lpOldProc)
lpOldProc = 0
End If
End Sub
Sub HookIt(hwnd As Long)
If Not lpOldProc Then
lpOldProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowFunction)
End If
End Sub
