Jaafar Tribak
Well-known Member
- Joined
- Dec 5, 2002
- Messages
- 9,596
- Office Version
- 2016
- Platform
- Windows
Hi all,
I was intrigued by the question posted here http://www.mrexcel.com/forum/showthread.php?t=295844 and after some experimentation i realised that it's not actually as easy as it first appears to show a tooltip window for each item of a DropDown as you hover over the items with the mouse.
even moving and toggling the visible Property at run time of a lbl and/or a textbox and use them to mimic a tooltip didn't help as the latters get overlapped by the dropdown.
Maybe i am just complicating things and am missing an easier solution/workaround !
Anyway here is a workbook example : http://www.savefile.com/files/1303707
and here is the code for future reference:
This Code goes in the UserForm Module:
this code goes in a Standard Module:
Tried in XL2003 French version.
Regards.
I was intrigued by the question posted here http://www.mrexcel.com/forum/showthread.php?t=295844 and after some experimentation i realised that it's not actually as easy as it first appears to show a tooltip window for each item of a DropDown as you hover over the items with the mouse.
even moving and toggling the visible Property at run time of a lbl and/or a textbox and use them to mimic a tooltip didn't help as the latters get overlapped by the dropdown.
Maybe i am just complicating things and am missing an easier solution/workaround !
Anyway here is a workbook example : http://www.savefile.com/files/1303707
and here is the code for future reference:
This Code goes in the UserForm Module:
Rich (BB code):
Option Explicit
Private Sub UserForm_Initialize()
Dim i As Byte
'poulate cmb and assign it to a global var
With ComboBox1
For i = 1 To 12
.AddItem i
Next
.ListIndex = 0
End With
Set oCmb = Me.ComboBox1
Call CreateStaticCtl
Call SubClassStaticCtl
End Sub
Private Sub UserForm_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Call ShowWnd(hWndStatic, 0)
End Sub
Private Sub UserForm_Terminate()
Call DestroyStaticCtl
End Sub
Private Sub ComboBox1_Change()
Call SethWndDropDownTimerToZero
End Sub
Private Sub ComboBox1_DropButtonClick()
hWndDropDown = GetWndUnderMouse
End Sub
Private Sub ComboBox1_MouseMove _
(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Dim i As Byte
'store the y mouse coordinate in a global var
CmbYpointer = y
'don't show tooltip if mouse outside the dropdown
If GetWndUnderMouse = hWndDropDown Or hWndDropDown = 0 _
Then _
Call ShowWnd(hWndStatic, 0): Exit Sub
'otherwise show the tooltip
Call ShowWnd(hWndStatic, 1)
lStringLenght = Len(sMessageString)
'compute the lStringLenght here so it
'can be used to determine the width of
'the tooltip dinamically in the "SetStaticPos" proc
lStringLenght = (lStringLenght \ 30) + 1
If lStringLenght = 0 Then lStringLenght = 1
With GetCursorPosition
Call SetStaticPos(hWndStatic, .x, .y)
End With
sMessageString = "This is some text for row # : "
Call ShowText(lRow)
If lRow = 1 Then
sMessageString = "This is some text for row # : "
sMessageString = sMessageString & CStr(lRow + 1) & vbTab
sMessageString = sMessageString & String(45, "-")
sMessageString = sMessageString & "This is some more text "
sMessageString = sMessageString & "to demonstrate that the height of "
sMessageString = sMessageString & "the tooltip control can also adjust "
sMessageString = sMessageString & "itself automatically to accomodate "
sMessageString = sMessageString & "all the text . "
End If
End Sub
Private Sub ShowText(ByVal row As Byte)
sMessageString = sMessageString & CStr(row + 1) & vbTab
End Subthis code goes in a Standard Module:
Rich (BB code):
Option Explicit
'****variables used in the UserForm module***
Public hWndStatic As Long
Public hWndDropDown As Long
Public lRow As Long
Public CmbYpointer As Double
Public lStringLenght As Long
Public sMessageString As String
Public oCmb As ComboBox
'***********************************
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type POINTAPI
x As Long
y As Long
End Type
Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Type PAINTSTRUCT
hdc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(32) As Byte
End Type
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As String * 1
lfUnderline As String * 1
lfStrikeOut As String * 1
lfCharSet As String * 1
lfOutPrecision As String * 1
lfClipPrecision As String * 1
lfQuality As String * 1
lfPitchAndFamily As String * 1
lfFaceName As String * 32
End Type
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private dFontHeight, dFontWidth As Double
Declare Function KillTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Declare Function SetTimer Lib "user32" _
(ByVal hWnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private lTimerID As Long
Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function SetBkMode Lib "gdi32" _
(ByVal hdc As Long, ByVal nBkMode As Long) As Long
Declare Function SetTextColor Lib "gdi32" _
(ByVal hdc As Long, ByVal crColor As Long) As Long
Declare Function DrawEdge Lib "user32" _
(ByVal hdc As Long, qrc As RECT, ByVal edge As Long, _
ByVal grfFlags As Long) As Long
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Declare Function DrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_LEFT = &H0
Private Const DT_WORDBREAK = &H10
Private Const DT_CALCRECT = &H400
Private Const DT_EDITCONTROL = &H2000
Private Const DT_NOCLIP = &H100
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
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 Const GWL_WNDPROC = (-4)
Private Const WM_MOVE = &H3
Private lPrevWnd As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" _
(ByVal hWnd As Long, ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private hdc As Long
Declare Function CreateBrushIndirect Lib "gdi32" _
(lpLogBrush As LOGBRUSH) As Long
Declare Function FillRect Lib "User32.dll" (ByVal hdc As Long, _
ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Declare Function SetRect Lib "user32" _
(lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function BeginPaint Lib "User32.dll" ( _
ByVal hWnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Declare Function EndPaint Lib "User32.dll" ( _
ByVal hWnd As Long, ByRef lpPaint As PAINTSTRUCT) As Long
Private Const RDW_INTERNALPAINT = &H2
Private Const WM_ACTIVATE = &H6
Private Const WM_PAINT = &HF
Private Const WM_DESTROY = &H2
Declare Function RedrawWindow Lib "user32" _
(ByVal hWnd As Long, lprcUpdate As Any, ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long
Private Const RDW_ERASE = &H4
Private Const RDW_INVALIDATE = &H1
Private Const RDW_ERASENOW = &H200
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
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
Declare Function GetClientRect Lib "User32.dll" ( _
ByVal hWnd As Long, ByRef lpRect As RECT) As Long
Private uClientArea As RECT
Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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 Const GWL_EXSTYLE = (-20)
Private Const WS_EX_TOOLWINDOW = &H80&
Private Const WS_CHILD = &H40000000
Private Const SS_CENTER = &H1
Private Const SW_HIDE = &H0
Private Const SW_NORMAL = 1
Private Const COLORR = 14811135 ' tooltipcolor
Declare Function ShowWindow Lib "user32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Declare Function GetDesktopWindow Lib "user32" () As Long
Declare Function DestroyWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Declare Function WindowFromPoint Lib "user32" _
(ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Function CallBack _
(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim uFont As LOGFONT
Dim lFHwnd, lOldFont As Long
Dim uP As POINTAPI
On Error Resume Next
'store the static cntl dc
hdc = GetDC(hWnd)
'store the static ctl area to be painted
GetClientRect hWnd, uClientArea
'catch the paint and move msgs
Select Case Msg
Case WM_PAINT
With uClientArea
'paint the static ctl and draw a frame on it
Call DrawRect _
(hWnd, .Left, .Top, .Right - .Left, .Bottom - .Top, 14811135)
DrawEdge hdc, uClientArea, EDGE_ETCHED, BF_RECT
End With
Case WM_MOVE
'create a new font for the static ctl text
With uFont
.lfFaceName = "Arial" & Chr$(0)
.lfHeight = 16 ' change these font params as required
.lfWidth = 6 '
'store the width and height in public vars
'so they can be used to set the dims of the static
'ctl in the userform module
dFontHeight = .lfHeight
dFontWidth = .lfWidth
End With
lFHwnd = CreateFontIndirect(uFont)
lOldFont = SelectObject(hdc, lFHwnd)
SetBkMode hdc, 1
'redraw the static ctl each time a new row of the
'combobox ia highlighted by the mouse pointer
If lRow <> Int(CmbYpointer / (8 + 1.75)) + oCmb.TopIndex Then
lRow = Int(CmbYpointer / (8 + 1.75)) + oCmb.TopIndex
RedrawWindow _
hWnd, ByVal 0&, ByVal 0&, RDW_ERASE + RDW_INVALIDATE
End If
DrawEdge hdc, uClientArea, EDGE_ETCHED, BF_RECT
'draw the text for each highlighted cmb row
DrawText _
hdc, sMessageString, Len(sMessageString), uClientArea, _
DT_NOCLIP + DT_LEFT + DT_EDITCONTROL + DT_WORDBREAK
Case WM_DESTROY
'Remove the wnd Subclassing
Call SetWindowLong(hWnd, GWL_WNDPROC, lPrevWnd)
End Select
'cleanup to avoid memory leaks!
SelectObject hdc, lOldFont
DeleteObject lFHwnd
ReleaseDC hWnd, hdc
CallBack = CallWindowProc(lPrevWnd, hWnd, Msg, wParam, ByVal lParam)
End Function
Private Sub DrawRect _
(lhwnd As Long, Left, Top, Width, Height, color)
Dim tPS As PAINTSTRUCT
Dim tLB As LOGBRUSH
Dim tR As RECT
Dim lDc As Long
Dim l As Long
Dim hBrush As Long
BeginPaint lhwnd, tPS
lDc = GetDC(lhwnd)
tLB.lbColor = color
'Create a new brush
hBrush = CreateBrushIndirect(tLB)
SetRect tR, Left, Top, Width, Height
'Fill the form with our brush
FillRect lDc, tR, hBrush
Call DeleteObject(hBrush)
RedrawWindow lhwnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
DeleteDC lDc
Call EndPaint(lhwnd, tPS)
End Sub
Sub CreateStaticCtl()
Const Width = 300 ' change these consts as required
Const Height = 25
With GetCursorPosition
hWndStatic = CreateWindowEx(WS_EX_TOOLWINDOW, "STATIC", _
vbNullString, SS_CENTER + WS_CHILD, .x, .y, Width, _
Height, GetDesktopWindow, 0, 0, 0)
End With
End Sub
Sub SubClassStaticCtl()
lPrevWnd = SetWindowLong(hWndStatic, GWL_WNDPROC, AddressOf CallBack)
End Sub
Function GetCursorPosition() As POINTAPI
Dim tP As POINTAPI
GetCursorPos tP
GetCursorPosition = tP
End Function
Function GetWndUnderMouse() As Long
Dim tP As POINTAPI
GetCursorPos tP
GetWndUnderMouse = WindowFromPoint(tP.x, tP.y)
End Function
Sub ShowWnd(hWnd As Long, Visible As Long)
ShowWindow hWnd, Visible
End Sub
Sub SetStaticPos _
(hWnd As Long, Left As Long, Top As Long)
'change thse constantes to suit
Const OffsetX = 30
Const OffsetY = 10
Const WidthFactor = 30
SetWindowPos hWnd, 0, Left + OffsetX, Top + OffsetY, _
dFontWidth * WidthFactor, dFontHeight * lStringLenght, 0
End Sub
Sub DestroyStaticCtl()
DestroyWindow hWndStatic
End Sub
Function GetDropDownhWnd() As Long
Dim tP As POINTAPI
GetCursorPos tP
GetDropDownhWnd = WindowFromPoint(tP.x, tP.y)
End Function
Sub SethWndDropDownTimerToZero()
lTimerID = SetTimer(0, 0, 1, AddressOf TimerCallback)
End Sub
Private Sub TimerCallback()
KillTimer 0, lTimerID
hWndDropDown = 0
End SubTried in XL2003 French version.
Regards.
