by Kaustubh Zoal (10 Submissions)
Category: Miscellaneous
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Fri 21st June 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
This VB program displays the Tool Tips in different styles It requires one form and one class module.
VBcoders
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
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_GETITEMRECT = &H198
Private Const LVM_FIRST = &H1000
Private Const LVM_GETITEMRECT = LVM_FIRST + 14
Private Const LVIR_BOUNDS = 0
Private Const LVIR_ICON = 1
Private Const LVIR_LABEL = 2
Private Const LVIR_SELECTBOUNDS = 3
Dim TTStd As New cToolTip
Dim TTBlnRed As New cToolTip
Dim TTBlnBlue As New cToolTip
Dim TTBlnGreen As New cToolTip
Private Sub Command1_Click()
If Left$(Command1.Caption, 1) = "R" Then
TTBlnRed.DelToolTip Command1.hwnd
Command1.Caption = "Set TT on Me"
Else
TTBlnRed.SetToolTipObj Command1.hwnd, "Multiline and balloon" & vbCrLf & "ToolTip sample" & vbCrLf & "for Command Button", False
Command1.Caption = "Remove TT from Me"
End If
End Sub
Private Sub Form_Load()
Dim rc As RECT, i As Long
Command1.Caption = "Remove TT from Me"
Option1(0).Caption = "Icon"
Option1(1).Caption = "SmallIcon"
Option1(2).Caption = "List"
Option1(3).Caption = "Report"
With TTBlnRed
.BkColor = vbRed
.TxtColor = vbBlack
.DelayTime = 300
.VisibleTime = 1000
.TipWidth = 10
.Style = ttStyleBalloon
.SetToolTipObj Command1.hwnd, "Multiline and balloon" & vbCrLf & "ToolTip sample" & vbCrLf & "for Command Button", False
End With
With TTBlnBlue
.BkColor = vbBlue
.TxtColor = vbWhite
.Style = ttStyleBalloon
For i = 0 To 3
.SetToolTipObj Option1(i).hwnd, "Choose ListView Style"
Next i
End With
With TTBlnGreen
.BkColor = vbGreen
.TxtColor = vbBlack
.Style = ttStyleBalloon
End With
With TTStd
.Style = ttStyleStandard
.DelayTime = 100
.VisibleTime = 1000
End With
For i = 0 To 20
List1.AddItem "This is item No. " & CStr(i)
SendMessage List1.hwnd, LB_GETITEMRECT, i, rc
TTStd.SetToolTipItem List1.hwnd, i, rc.Left, rc.Top, rc.Right, rc.Bottom, "Multiline and Centered long Tooltip style example" & vbCrLf & "for item No. " & CStr(i), True
Next i
For i = 1 To 30
With ListView1.ListItems.Add(, , "ListView Item No. " & CStr(i))
.Icon = 1
.SmallIcon = 1
End With
rc.Left = LVIR_BOUNDS
SendMessage ListView1.hwnd, LVM_GETITEMRECT, i - 1, rc
TTBlnGreen.SetToolTipItem ListView1.hwnd, i - 1, rc.Left, rc.Top, rc.Right, rc.Bottom, "ListView Tooltip example" & vbCrLf & "for item No. " & CStr(i)
Next
Option1(0).Value = True
'center
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set TTBlnRed = Nothing
Set TTBlnBlue = Nothing
Set TTStd = Nothing
End Sub
Private Sub List1_Scroll()
Dim rc As RECT, i As Long
For i = 0 To List1.ListCount - 1
SendMessage List1.hwnd, LB_GETITEMRECT, i, rc
TTStd.AjustItemRect List1.hwnd, i, rc.Left, rc.Top, rc.Right, rc.Bottom
Next i
End Sub
Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim rc As RECT, i As Long
For i = 1 To ListView1.ListItems.Count
rc.Left = LVIR_BOUNDS
SendMessage ListView1.hwnd, LVM_GETITEMRECT, i - 1, rc
TTBlnGreen.AjustItemRect ListView1.hwnd, i - 1, rc.Left, rc.Top, rc.Right, rc.Bottom
Next i
End Sub
Private Sub Option1_Click(Index As Integer)
ListView1.View = Index
End Sub
------------------------------------------------------------------------------------
cToolTip Code :
Option Explicit
'Initialization of New ClassNames
Private Const ICC_BAR_CLASSES = &H4 'toolbar, statusbar, trackbar, tooltips
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean
Private Type tagINITCOMMONCONTROLSEX
dwSize As Long ' size of this structure
dwICC As Long ' flags indicating which classes to be initialized.
End Type
' ToolTip Styles
Private Const TTS_ALWAYSTIP = &H1
Private Const TTS_NOPREFIX = &H2
Private Const TTS_BALLOON = &H40 ' comctl32.dll v5.8 require
Private Const CW_USEDEFAULT = &H80000000
Private Const WS_POPUP = &H80000000
Private Const WM_USER = &H400
' ToolTip Messages
Private Const TTM_SETDELAYTIME = (WM_USER + 3)
Private Const TTM_ADDTOOL = (WM_USER + 4)
Private Const TTM_DELTOOL = (WM_USER + 5)
Private Const TTM_NEWTOOLRECT = (WM_USER + 6)
Private Const TTM_GETTOOLINFO = (WM_USER + 8)
Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19)
Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20)
Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24)
Private Const TTDT_AUTOPOP = 2
Private Const TTDT_INITIAL = 3
Private Const TTF_IDISHWND = &H1
Private Const TTF_CENTERTIP = &H2
Private Const TTF_SUBCLASS = &H10
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private 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 Enum TTStyle
ttStyleStandard = 1
ttStyleBalloon = 2
End Enum
Private 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 Declare Function DestroyWindow Lib "user32" (ByVal hwnd 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
Private 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
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_STYLE = (-16)
Private hTT As Long
'local variable(s) to hold property value(s)
Private mvarTipWidth As Long 'local copy
Private mvarDelayTime As Long 'local copy
Private mvarVisibleTime As Long 'local copy
Private mvarBkColor As Long 'local copy
Private mvarTxtColor As Long 'local copy
Private mvarStyle As TTStyle 'local copy
Public Property Let TxtColor(ByVal vData As Long)
mvarTxtColor = vData
SendMessageLong hTT, TTM_SETTIPTEXTCOLOR, vData, 0&
End Property
Public Property Get TxtColor() As Long
TxtColor = mvarTxtColor
End Property
Public Property Let BkColor(ByVal vData As Long)
mvarBkColor = vData
SendMessageLong hTT, TTM_SETTIPBKCOLOR, vData, 0&
End Property
Public Property Get BkColor() As Long
BkColor = mvarBkColor
End Property
Public Property Let VisibleTime(ByVal vData As Long)
mvarVisibleTime = vData
SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, vData
End Property
Public Property Get VisibleTime() As Long
VisibleTime = mvarVisibleTime
End Property
Public Property Let DelayTime(ByVal vData As Long)
mvarDelayTime = vData
SendMessageLong hTT, TTM_SETDELAYTIME, TTDT_INITIAL, vData
End Property
Public Property Get DelayTime() As Long
DelayTime = mvarDelayTime
End Property
Public Property Let TipWidth(ByVal vData As Long)
mvarTipWidth = vData
SendMessageLong hTT, TTM_SETMAXTIPWIDTH, 0, vData
End Property
Public Property Get TipWidth() As Long
TipWidth = mvarTipWidth
End Property
Public Property Let Style(ByVal vData As TTStyle)
Dim lStyle As Long
mvarStyle = vData
If hTT Then
lStyle = GetWindowLong(hTT, GWL_STYLE)
If vData = ttStyleBalloon Then lStyle = lStyle Or TTS_BALLOON
If vData = ttStyleStandard And (lStyle And ttStyleBalloon) Then lStyle = lStyle Xor TTS_BALLOON
SetWindowLong hTT, GWL_STYLE, lStyle
End If
End Property
Public Property Get Style() As TTStyle
Style = mvarStyle
End Property
Private 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 SetToolTipObj(objHwnd As Long, sTipText As String, Optional bCenter As Boolean = False)
Dim TI As TOOLINFO
With TI
.hwnd = objHwnd
.uFlags = TTF_IDISHWND Or TTF_SUBCLASS
If bCenter Then
.uFlags = .uFlags Or TTF_CENTERTIP
End If
.uId = objHwnd
.lpszText = sTipText
.cbSize = Len(TI)
End With
SendMessage hTT, TTM_ADDTOOL, 0, TI
End Sub
Public Sub SetToolTipItem(objHwnd As Long, nItem As Long, lft As Long, tp As Long, rght As Long, btm As Long, sTipText As String, Optional bCenter As Boolean = False)
Dim TI As TOOLINFO, rc As RECT
rc.Bottom = btm
rc.Left = lft
rc.Right = rght
rc.Top = tp
With TI
.cRect = rc
.hwnd = objHwnd
.uFlags = TTF_SUBCLASS
If bCenter Then
.uFlags = .uFlags Or TTF_CENTERTIP
End If
.uId = nItem
.lpszText = sTipText
.cbSize = Len(TI)
End With
SendMessage hTT, TTM_ADDTOOL, 0, TI
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 AjustItemRect(objHwnd As Long, nItem As Long, lft As Long, tp As Long, rght As Long, btm As Long)
Dim TI As TOOLINFO, rc As RECT
With TI
.hwnd = objHwnd
.uId = nItem
.cbSize = Len(TI)
End With
SendMessage hTT, TTM_GETTOOLINFO, 0&, TI
rc.Bottom = btm
rc.Left = lft
rc.Right = rght
rc.Top = tp
TI.cRect = rc
SendMessage hTT, TTM_NEWTOOLRECT, 0&, TI
End Sub
Private Sub Class_Initialize()
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&)
Style = ttStyleStandard
TipWidth = 300
BkColor = &HEEFFFF
TxtColor = vbBlack
DelayTime = 500
VisibleTime = 2000
End Sub
Private Sub Class_Terminate()
If hTT Then DestroyWindow (hTT)
End Sub
No comments have been posted about This VB program displays the Tool Tips in different styles It requires one form and one class modul. Why not be the first to post a comment about This VB program displays the Tool Tips in different styles It requires one form and one class modul.
