ComboBox и ToolTipText

[Diac]

Всем привет. Кто знает как можно в VB6 сделать, чтобы при наведении курсора мыши на строчку ниспадающей части ComboBox' а всплывающая подсказка отображала текст этой строки?

[A.A.Z.]

Ох, нелегкая это работа - Tooltip'ы самому делать...
1) На форму добавь Combo1 (сразу натыкай туда каких-нибудь надписей) и Timer1 с интервалом 1.
2) Это в форму:

Код: Выделить всё

Dim Clicked As Boolean

Private Sub Combo1_Click()
Clicked = Not Clicked
End Sub

Private Sub Combo1_GotFocus()
Clicked = True
End Sub

Private Sub Combo1_LostFocus()
Clicked = False
End Sub

Private Sub Timer1_Timer()
Dim P As POINTAPI
Static S1$, S2$
If Clicked Then
GetCursorPos P
S2 = Combo1.List(Combo1.ListIndex)
If S1 <> S2 Then
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
InitializeTT
AddToolTip P.X, P.Y, Combo1.hWnd, S2, True
S1 = S2
End If
End If
End Sub

3) Это в модуль под названием modGlobal:

Код: Выделить всё

Public Const LF_FACESIZE = 32
Public Const ICC_BAR_CLASSES = &H4
Public Const TTS_ALWAYSTIP = &H1
Public Const TTS_NOPREFIX = &H2
Public Const TTS_BALLOON = &H40
Public Const CW_USEDEFAULT = &H80000000
Public Const WS_POPUP = &H80000000
Public Const WM_USER = &H400
Public Const TTM_SETDELAYTIME = (WM_USER + 3)
Public Const TTM_ADDTOOL = (WM_USER + 4)
Public Const TTM_DELTOOL = (WM_USER + 5)
Public Const TTM_NEWTOOLRECT = (WM_USER + 6)
Public Const TTM_GETTOOLINFO = (WM_USER + 8)
Public Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Public Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Public Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Public Const TTDT_AUTOPOP = 2
Public Const TTDT_INITIAL = 3
Public Const TTM_TRACKACTIVATE = WM_USER + 17
Public Const TTM_TRACKPOSITION = WM_USER + 18
Public Const TTF_IDISHWND = &H1
Public Const TTF_CENTERTIP = &H2
Public Const TTF_SUBCLASS = &H10
Public Const TTF_TRACK = &H20
Public Const TTF_ABSOLUTE = &H80
Public Const WM_SETFONT = &H30
Public Const SW_SHOW = 5
Public Const SW_HIDE = 0
Public Const GWL_STYLE = (-16)
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOACTIVATE = &H10
Public Const SWP_SHOWWINDOW = &H40

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Public Type POINTAPI
X As Long
Y As Long
End Type

Public Type TOOLINFO
cbSize As Long
uFlags As Long
hWnd As Long
uId As Long
cRect As RECT
hinst As Long
lpszText As String
End Type

Public Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type

Public Type Size
cx As Long
cy As Long
End Type

Public Type tagINITCOMMONCONTROLSEX
dwSize As Long
dwICC As Long
End Type

Public Enum TTStyle
ttStyleStandard = 1
ttStyleBalloon = 2
End Enum

Public Declare Function MoveWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Public Declare Function ShowWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (ByRef lpLogFont As LOGFONT) As Long
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Public Declare Function GetCharWidth32 Lib "gdi32.dll" Alias "GetCharWidth32A" (ByVal hdc As Long, ByVal iFirstChar As Long, ByVal iLastChar As Long, ByRef lpBuffer As Long) As Long
Public Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, ByRef lpSize As Size) As Long
Public Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Public Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Public Declare Function InitCommonControlsEx Lib "comctl32.dll" (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean
Public Declare Function GetWindowRect Lib "user32.dll" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
Public 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
Public Declare Function DestroyWindow Lib "User32" (ByVal hWnd As Long) As Long
Public Declare Function SendMessageLong Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal i As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Public Declare Function SetParent Lib "User32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Public Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "User32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Sub 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)
Public Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Public Declare Sub InitCommonControls Lib "comctl32.dll" ()

Public hTT As Long
Public mvarTipWidth As Long
Public mvarDelayTime As Long
Public mvarVisibleTime As Long
Public mvarBkColor As Long
Public mvarTxtColor As Long
Public mvarStyle As TTStyle
Public mvarFont As StdFont

Public Sub InitComctl32(dwFlags As Long)
Dim icc As tagINITCOMMONCONTROLSEX
On Error GoTo Err_OldVersion
icc.dwSize = Len(icc)
icc.dwICC = dwFlags
InitCommonControlsEx icc
On Error GoTo 0
Exit Sub
Err_OldVersion:
InitCommonControls
End Sub

Public Sub AddToolTip(ByVal X As Long, ByVal Y As Long, objHwnd As Long, sTipText As String, Optional bCenter As Boolean = False)
Dim TI As TOOLINFO
With TI
.hWnd = objHwnd
.uFlags = TTF_IDISHWND Or TTF_TRACK Or TTF_ABSOLUTE
If bCenter Then
.uFlags = .uFlags Or TTF_CENTERTIP
End If
.uId = objHwnd
.lpszText = sTipText
.cbSize = Len(TI)
End With
SendMessage hTT, TTM_TRACKPOSITION, 0, MakLng(0, 0)
SendMessage hTT, TTM_ADDTOOL, 0, TI
SendMessage hTT, TTM_TRACKACTIVATE, ByVal True, TI
MoveWindow hTT, X, Y, 8 + GetTextSize(hTT, sTipText), 4 + GetTextSize(hTT, sTipText, True), True
SetWindowPos hTT, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_SHOWWINDOW Or SWP_NOMOVE Or SWP_NOSIZE
End Sub

Public Sub DelToolTip(objHwnd As Long, Optional nItem As Long = -1)
Dim TI As TOOLINFO
TI.hWnd = objHwnd
TI.cbSize = Len(TI)
If nItem < 0 Then TI.uId = objHwnd Else TI.uId = nItem
SendMessage hTT, TTM_DELTOOL, 0, TI
End Sub

Public Sub InitializeTT()
InitComctl32 ICC_BAR_CLASSES
hTT = CreateWindowEx(0, "tooltips_class32", 0&, TTS_NOPREFIX Or TTS_ALWAYSTIP, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0&, 0&, App.hInstance, 0&)
Dim lStyle As Long
lStyle = GetWindowLong(hTT, GWL_STYLE)
lStyle = lStyle Xor TTS_ALWAYSTIP
SetWindowLong hTT, GWL_STYLE, lStyle
SendMessageLong hTT, TTM_SETMAXTIPWIDTH, 0, 2
SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_INITIAL, 1
SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, 32000
End Sub

Public Sub DestroyCurrentToolTip()
If hTT Then DestroyWindow (hTT)
If Not mvarFont Is Nothing Then DeleteObject ObjPtr(mvarFont)
End Sub

Property Get hWnd() As Long
hWnd = hTT
End Property

Public Function HiWord(DWord As Long) As Integer
HiWord = (DWord And &HFFFF0000) \ &H10000
End Function

Public Function LoWord(DWord As Long) As Integer
LoWord = IIf(DWord And &H8000&, DWord Or &HFFFF0000, DWord And &HFFFF&)
End Function

Public Function MakLng(X As Integer, Y As Integer) As Long
MakLng = X + (Y * &H10000)
End Function

Public Function FontInfo(ByVal hCtlWnd As Long)
Dim VarFontInfo As LOGFONT, hFont As Long
hFont = CreateFontIndirect(VarFontInfo)
hCtlDc = GetDC(hCtlWnd)
Dim hFont2 As Long
hFont2 = SelectObject(hCtlDc, hFont)
CopyMemory VarFontInfo, ByVal hFont, Len(VarFontInfo)
MsgBox VarFontInfo.lfHeight
End Function

Public Function FontWidth(ByVal hCtlWnd As Long, ByVal StrLen As Long) As Long
Dim hCtlDc As Long, VarFontWidth As Long
hCtlDc = GetDC(hCtlWnd)
MsgBox GetCharWidth32(hCtlDc, 1, StrLen - 1, VarFontWidth)
MsgBox VarFontWidth
End Function

Public Function GetTextSize(ByVal hWnd As Long, strText As String, Optional ByVal HeightTrue As Boolean = False) As Long
Dim hdc As Long, hFont As Long, sz As Size
hdc = GetDC(hWnd)
Const WM_GETFONT = &H31
hFont = SendMessage(hWnd, WM_GETFONT, 0, 0)
hFont = SelectObject(hdc, hFont)
GetTextExtentPoint32 hdc, strText, Len(strText), sz
SelectObject hdc, hFont
ReleaseDC hWnd, hdc
If HeightTrue Then GetTextSize = sz.cy Else GetTextSize = sz.cx
End Function

Вроде работает, но, как мне кажется, тут есть недоработки. Придут гуру и поправят меня в чем-нибудь

[Diac]

Спасибо A.A.Z. Кто бы мог подумать, что все так сложно. Работает, но подсказка остается висеть все время, пока работает программа. Был бы еще очень благодарен, если бы было хоть немного объяснений к коду, который в модуле.

[A.A.Z.]

Уф
Ща, попробуем объяснить... Погоди немного

[A.A.Z.]

До меня дошло Поменяй код процедуры Timer1_Timer на следующий:

Код: Выделить всё

Private Sub Timer1_Timer()
Dim P As POINTAPI
Static S1$, S2$
If Clicked Then
GetCursorPos P
S2 = Combo1.List(Combo1.ListIndex)
If S1 <> S2 Then
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
InitializeTT
AddToolTip P.X, P.Y, Combo1.hWnd, S2, True
S1 = S2
Else
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
End If
End If
End Sub


[Diac]

Теперь лучше. Подсказка теперь держится столько, какой interval у таймера. В принципе, если выставить интервал = 6000, то подсказку можно успеть прочитать.

[Diac]

Хотя, если щелкнешь по строчке combobox' а, пока подсказка висит, эта подсказка потом остается. Но, чтобы, если combobox теряет фокус подсказка исчезала я к этому коду прибавил чуть-чуть.

Код: Выделить всё

Private Sub Timer1_Timer()
Dim P As POINTAPI
Static S1$, S2$
If Clicked Then
GetCursorPos P
S2 = Combo1.List(Combo1.ListIndex)
If S1 <> S2 Then
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
InitializeTT
AddToolTip P.X, P.Y, Combo1.hWnd, S2, True
S1 = S2
Else
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
End If
End If
If Clicked = False Then
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
End If
End Sub

Подсказка стала уходить

[A.A.Z.]

Ну вот и хорошо, если все работает как надо

[Diac]

Все равно не понятно, почему нельзя обойтись без API.

[A.A.Z.]

А как ты заставишь Tooltip появится без API? Если только свой ActiveX делать...

[Diac]

A может проще Active X сделать?

[A.A.Z.]

Ну, не знаю... Я еще раз говорю, я немного криво сделал создание ToolTip'ов, просто надеялся, что придут гуру вроде GSerg'а или tyomitch'а и сделают, как надо

[GSerg]

Тёмыч ближайшие 3 дня появляться не должен, а я спать хочу

Сделайте, в конце концов, имитатор тултипа
Плоскую жёлтую форму без заголовка и границ

Ой, кошмар какой

[Diac]

Сделайте, в конце концов, имитатор тултипа
Плоскую жёлтую форму без заголовка и границ

Это хорошо, но как сделать, чтобы при наведении мыши на строчку ниспадающей части комбобокса появлялась эта форма? Ведь события MousMove для него не предусмотрено!

[A.A.Z.]

Дык а как я, собственно, заставлял ToolTip появиться?

[Diac]

Так я же как раз и просил немного объяснить этот код.

[A.A.Z.]

Код: Выделить всё

Private Sub Timer1_Timer()
Dim P As POINTAPI
Static S1$, S2$
If Clicked Then                    'Если на комбобокс нажали, и
GetCursorPos P
S2 = Combo1.List(Combo1.ListIndex) 'если в комбобоксе выделен не тот элемент,
If S1 <> S2 Then                   'что и раньше, то удалить старый и сделать новый.
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
InitializeTT
AddToolTip P.X, P.Y, Combo1.hWnd, S2, True
S1 = S2
Else                               'Если нет, то при наличии старого тултипа удалить его.
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
End If
End If
If Clicked = False Then
DelToolTip modGlobal.hWnd
DestroyCurrentToolTip
End If

Тут принцип прост: каждые 16 мс мы проверяем, если комбо все еще открыт, то тултип либо сделать новый (если выделенный элемент сменился), либо оставить все как есть. А если комбо закрыли или вовсе не открывали, то убрать существующий тултип (если он есть), или оставить все как есть (если его уже нет).
Можно, конечно, попробовать отловить пространство, занимаемое выпадающим списком, но там геморроя тоже будет много...

[Diac]

Тут я нашел в сатье Михаила Эскина такую вот штуку для ListBox'a

Создание расширения для ListBox: Свойство - «Вывод в виде подсказки ToolTyp длинных элементов списка»

Код: Выделить всё

Option Explicit
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
Private Const LB_ITEMFROMPOINT = &H1A9 'константа API-функции
Private Const m_def_ToolTypLong = True 'константа контрола
Dim m_ToolTypLong As Boolean 'переменная контрола
'Масштабирование ListBox - необязательно. Здесь показывается с чисто эстетических позиций
Private Sub UserControl_Resize()
List1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
'Данная функция здесь показана для удобства пользователя (проведение тестирования)
Public Sub AddItem(ByVal Item As String, Optional ByVal Index As Variant)
List1.AddItem Item, Index
End Sub
Private Sub UserControl_InitProperties()
m_ToolTypLong = m_def_ToolTypLong
End Sub
'данное свойство руководит выводом или невыводом подсказки
Public Property Get ToolTypLong() As Boolean
ToolTypLong = m_ToolTypLong
End Property
Public Property Let ToolTypLong(ByVal New_ToolTypLong As Boolean)
m_ToolTypLong = New_ToolTypLong
PropertyChanged "ToolTypLong"
End Property

Private Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lXPoint As Long, lYPoint As Long, lIndex As Long
'если не нажата никакая клавиша мыши и свойство ToolTypLong установлено в True
If (Button = 0) And (m_ToolTypLong = True) Then
'перевод в пикселы
lXPoint = CLng(X / Screen.TwipsPerPixelX)
lYPoint = CLng(Y / Screen.TwipsPerPixelY)
With List1
'выбирает индекс списка, в зависимости от позиции курсора
lIndex = SendMessage(.hwnd, LB_ITEMFROMPOINT, 0, _
ByVal ((lYPoint * 65536) + lYPoint))
'если курсор вне записей списка
If (lIndex >= 0) And (lIndex <= .ListCount) Then
.ToolTipText = .List(lIndex)
Else
.ToolTipText = vbNullString
End If
End With
End If
End Sub
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_ToolTypLong = PropBag.ReadProperty("ToolTypLong", m_def_ToolTypLong)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("ToolTypLong", m_ToolTypLong, m_def_ToolTypLong)
End Sub


Может как-то это можно модифицировать для ComboBox'a?

[GSerg]

Дык а комбо - это по-твоему что?

Зацени сообщение CB_GETCOMBOBOXINFO. Получишь хэндл внутреннего листбокса.

[Diac]

Дык а комбо - это по-твоему что?

Насколько я понимаю комбо это гибрид листбокса и текстбокса, но, в примере кода для листбокса есть событие MousMove, а для списка у комбобокса его нет.

Зацени сообщение CB_GETCOMBOBOXINFO. Получишь хэндл внутреннего листбокса.

А вот в этом-то, признаться я совсем туго разбираюсь.