Sección de códigos , trucos y ejemplos para visual basic

407 - MultilineToolTip en ListView y Treeview

Ejemplo para desplegar un Tip de información en controles Listview y Treeview

Agregar en un nuevo proyecto, un módulo de clase llamado Class1

Código fuente de Class1

Option Explicit 'declaraciones Api '''''''''''''''''''''''''''''''''' Private Declare Sub InitCommonControls Lib "comctl32.dll" () 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 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 DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long 'Constantes y UDT '''''''''''''''''''''''''''''''''' Private Const WM_USER = &H400 Private Const CW_USEDEFAULT = &H80000000 Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Const TTS_NOPREFIX = &H2 Private Const TTF_TRANSPARENT = &H100 Private Const TTF_CENTERTIP = &H2 Private Const TTM_ADDTOOLA = (WM_USER + 4) Private Const TTM_ACTIVATE = WM_USER + 1 Private Const TTM_UPDATETIPTEXTA = (WM_USER + 12) Private Const TTM_SETMAXTIPWIDTH = (WM_USER + 24) Private Const TTM_SETTIPBKCOLOR = (WM_USER + 19) Private Const TTM_SETTIPTEXTCOLOR = (WM_USER + 20) Private Const TTM_SETTITLE = (WM_USER + 32) Private Const TTS_BALLOON = &H40 Private Const TTS_ALWAYSTIP = &H1 Private Const TTF_SUBCLASS = &H10 Private Const TTF_IDISHWND = &H1 Private Const TTM_SETDELAYTIME = (WM_USER + 3) Private Const TTDT_AUTOPOP = 2 Private Const TTDT_INITIAL = 3 Private Const TOOLTIPS_CLASSA = "tooltips_class32" Private Type TOOLINFO lSize As Long lFlags As Long hwnd As Long lId As Long lpRect As RECT hInstance As Long lpStr As String lParam As Long End Type Public Enum ttIconType TTNoIcon = 0 TTIconInfo = 1 TTIconWarning = 2 TTIconError = 3 End Enum Public Enum ttStyleEnum TTStandard TTBalloon End Enum Private mvarBackColor As Long Private mvarTitle As String Private mvarForeColor As Long Private mvarIcon As ttIconType Private mvarCentered As Boolean Private mvarStyle As ttStyleEnum Private mvarTipText As String Private mvarVisibleTime As Long Private mvarDelayTime As Long Private m_lTTHwnd As Long Private m_lParentHwnd As Long Private ti As TOOLINFO Public Property Let Style(ByVal vData As ttStyleEnum) mvarStyle = vData End Property Public Property Get Style() As ttStyleEnum Style = mvarStyle End Property Public Property Let Centered(ByVal vData As Boolean) mvarCentered = vData End Property Public Property Get Centered() As Boolean Centered = mvarCentered End Property Public Function Create(ByVal ParentHwnd As Long) As Boolean Dim lWinStyle As Long If m_lTTHwnd <> 0 Then DestroyWindow m_lTTHwnd End If m_lParentHwnd = ParentHwnd lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX If mvarStyle = TTBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON m_lTTHwnd = CreateWindowEx(0&, _ TOOLTIPS_CLASSA, _ vbNullString, _ lWinStyle, _ CW_USEDEFAULT, _ CW_USEDEFAULT, _ CW_USEDEFAULT, _ CW_USEDEFAULT, _ 0&, _ 0&, _ App.hInstance, _ 0&) With ti If mvarCentered Then .lFlags = TTF_SUBCLASS Or TTF_CENTERTIP Or TTF_IDISHWND Else .lFlags = TTF_SUBCLASS Or TTF_IDISHWND End If .hwnd = m_lParentHwnd .lId = m_lParentHwnd '0 .hInstance = App.hInstance .lSize = Len(ti) End With SendMessage m_lTTHwnd, TTM_ADDTOOLA, 0&, ti If mvarTitle <> vbNullString Or mvarIcon <> TTNoIcon Then SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle End If If mvarForeColor <> Empty Then SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0& End If If mvarBackColor <> Empty Then SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0& End If SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_AUTOPOP, mvarVisibleTime SendMessageLong m_lTTHwnd, TTM_SETDELAYTIME, TTDT_INITIAL, mvarDelayTime End Function Public Property Let Icon(ByVal vData As ttIconType) mvarIcon = vData If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle End If End Property Public Property Get Icon() As ttIconType Icon = mvarIcon End Property Public Property Let ForeColor(ByVal vData As Long) mvarForeColor = vData If m_lTTHwnd <> 0 Then SendMessage m_lTTHwnd, TTM_SETTIPTEXTCOLOR, mvarForeColor, 0& End If End Property Public Property Get ForeColor() As Long ForeColor = mvarForeColor End Property Public Property Let Title(ByVal vData As String) mvarTitle = vData If m_lTTHwnd <> 0 And mvarTitle <> Empty And mvarIcon <> TTNoIcon Then SendMessage m_lTTHwnd, TTM_SETTITLE, CLng(mvarIcon), ByVal mvarTitle End If End Property Public Property Get Title() As String Title = ti.lpStr End Property Public Property Let BackColor(ByVal vData As Long) mvarBackColor = vData If m_lTTHwnd <> 0 Then SendMessage m_lTTHwnd, TTM_SETTIPBKCOLOR, mvarBackColor, 0& End If End Property Public Property Get BackColor() As Long BackColor = mvarBackColor End Property Public Property Let TipText(ByVal vData As String) mvarTipText = vData ti.lpStr = vData If m_lTTHwnd <> 0 Then SendMessage m_lTTHwnd, TTM_UPDATETIPTEXTA, 0&, ti End If End Property Public Property Get TipText() As String TipText = mvarTipText End Property Private Sub Class_Initialize() InitCommonControls mvarDelayTime = 500 mvarVisibleTime = 5000 End Sub Private Sub Class_Terminate() Destroy End Sub Public Sub Destroy() If m_lTTHwnd <> 0 Then DestroyWindow m_lTTHwnd End If End Sub Public Property Get VisibleTime() As Long VisibleTime = mvarVisibleTime End Property Public Property Let VisibleTime(ByVal lData As Long) mvarVisibleTime = lData End Property Public Property Get DelayTime() As Long DelayTime = mvarDelayTime End Property Public Property Let DelayTime(ByVal lData As Long) mvarDelayTime = lData End Property

Para usarlo desde un TreeView

Option Explicit Dim tTip As class1 Private Sub Form_Load() Dim i As Integer ' Crea un nodo TreeView1.Nodes.Add , , "root", "Principal" 'agrega algunos elementos al treeview For i = 0 To 50 With TreeView1.Nodes .Add "root", tvwChild, , "Elemento :" & i End With Next ' nueva instancia Set tTip = New class1 tTip.Style = TTBalloon ' tipo de toolT tTip.Icon = TTIconInfo ' tipo de icon tTip.DelayTime = 50 ' delay End Sub Private Sub TreeView1_MouseMove(Button As Integer, _ Shift As Integer, _ x As Single, y As Single) Static ItemActual As Long Dim texto As String Dim item As Node ' referencia al nodo donde está el mouse Set item = TreeView1.HitTest(x, y) ' si no hay un nodo seleccionado sale If item Is Nothing Then Exit Sub If ItemActual <> item.Index Then ItemActual = item.Index tTip.Destroy ' destruye tTip.Title = "Ejemplo" ' titulo tTip.TipText = item.Text ' El texto tTip.Create TreeView1.hwnd ' Lo crea End If End Sub

Para usarlo con un ListView

Option Explicit Dim tTip As class1 Const PATH As String = "c:\windows\" Private Sub Form_Load() Dim i As Integer Dim Archivo As String Archivo = Dir(PATH & "*.bmp") While Archivo <> "" ' agrega algunos elementos 'For i = 0 To 50 With ListView1.ListItems .Add , , Archivo End With 'Next Archivo = Dir Wend ' nueva instancia Set tTip = New class1 tTip.BackColor = &H80C0FF tTip.Style = TTBalloon ' tipo de toolT tTip.Icon = TTIconInfo ' tipo de icon tTip.DelayTime = 50 ' delay End Sub Private Sub ListView1_MouseMove(Button As Integer, _ Shift As Integer, _ X As Single, Y As Single) Static ItemActual As Long Dim texto As String Dim item As ListItem ' referencia al item donde está el mouse Set item = ListView1.HitTest(X, Y) ' si no hay seleccionado sale If item Is Nothing Then Exit Sub If ItemActual <> item.Index Then tTip.Destroy texto = "Fecha de creación: " & FileDateTime(PATH & item.Text) & vbNewLine texto = texto & "Tamaño: " & FileLen(PATH & item.Text) & " bytes" ItemActual = item.Index tTip.Title = item.Text ' titulo tTip.TipText = texto ' El texto tTip.Create ListView1.hwnd ' Lo crea End If End Sub

Enlaces relacionados

Ejemplos relacionados con ToolTips y BalloonTips en vb

Buscar en Recursos vb