• Home
 · 
• Miscellaneous
 · 
• This VB program displays the Tool Tips in different styles It requires one form and one class modul

This VB program displays the Tool Tips in different styles It requires one form and one class modul

This VB program displays the Tool Tips in different styles It requires one form and one class module.

Rate This VB program displays the Tool Tips in different styles It requires one form and one class modul

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

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