dcsimg
Results 1 to 5 of 5

Thread: [RESOLVED] EXCEL LISTVIEW AND Tooltips For Listitems In Listview

  1. #1

    Thread Starter
    Frenzied Member
    Join Date
    Mar 2005
    Location
    Italy-Napoli
    Posts
    1,742

    Resolved [RESOLVED] EXCEL LISTVIEW AND Tooltips For Listitems In Listview

    In a vba listview possible a tooltip in column 3 and 4, and show the value of listitem subitems(11)?

  2. #2
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    4,579

    Re: EXCEL LISTVIEW AND Tooltips For Listitems In Listview

    Luca,

    Where are you getting your ListView? If you're getting it from MSComCtl.ocx, I can absolutely give you tooltips for each SubItem. It'll take me a second, but I'll post that code in a moment. It's actually coming out of a VB6 project, but it should work just fine in VBA-32-bit. Also, it should be fairly easily adaptable to any ListView.

    Elroy
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  3. #3
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    4,579

    Re: EXCEL LISTVIEW AND Tooltips For Listitems In Listview

    Here you go. I rather harshly ripped this out of a functioning project, but it's got all the pieces there.

    The Form1 code is as follows, but I've also attached it as a functioning VBP project. This functioning VBP project is a VB6 project, but these same ideas should work just fine in a VBA-32-bit project.

    Enjoy,
    Elroy

    Code:
    
    Option Explicit
    '
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
    Private Type RECT
        Left   As Long
        Top    As Long
        Right  As Long ' This is +1 (right - left = width)
        Bottom As Long ' This is +1 (bottom - top = height)
    End Type
    '
    Private Type LVHITTESTINFO
        pt As POINTAPI
        lFlags As Long
        lItem As Long
        lSubItem As Long
    End Type
    '
    Private Const LVM_FIRST              As Long = &H1000&
    Private Const LVM_GETNEXTITEM        As Long = (LVM_FIRST + 12&)
    Private Const LVM_HITTEST            As Long = (LVM_FIRST + 18&)
    Private Const LVM_SETITEMSTATE       As Long = (LVM_FIRST + 43&)
    Private Const LVM_SUBITEMHITTEST     As Long = (LVM_FIRST + 57&)
    '
    Private 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
    Private Declare Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '
    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
    '
    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 DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
    '
    Private Const WM_USER = &H400
    Private Const CW_USEDEFAULT = &H80000000
    '
    Private Const TTM_ACTIVATE = WM_USER + 1
    Private Const TTM_ADDTOOLA = WM_USER + 4
    Private Const TTM_SETDELAYTIME = WM_USER + 3
    Private Const TTM_UPDATETIPTEXTA = WM_USER + 12
    Private Const TTM_SETTIPBKCOLOR = WM_USER + 19
    Private Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
    Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
    Private Const TTM_SETTITLE = WM_USER + 32
    '
    Private Const TTS_NOPREFIX = &H2
    Private Const TTS_BALLOON = &H40
    Private Const TTS_ALWAYSTIP = &H1
    '
    Private Const TTF_CENTERTIP = &H2
    Private Const TTF_IDISHWND = &H1
    Private Const TTF_SUBCLASS = &H10
    Private Const TTF_TRANSPARENT = &H100
    '
    Private Const TTDT_AUTOPOP = 2
    Private Const TTDT_INITIAL = 3
    '
    Private Const TOOLTIPS_CLASSA = "tooltips_class32"
    '
    Public Enum ttIconType
        TTNoIcon = 0
        TTIconInfo = 1
        TTIconWarning = 2
        TTIconError = 3
    End Enum
    #If False Then ' Intellisense fix.
        Public TTNoIcon, TTIconInfo, TTIconWarning, TTIconError
    #End If
    '
    Private hwndTT As Long ' hwnd of the tooltip
    '
    
    Private Sub Form_Load()
        Dim i As Long
        Dim Item As ListItem
        '
        For i = 1 To 10
            Set Item = lsvGoals.ListItems.Add
            Item.Text = vbNullString
            Item.SubItems(1) = Format$(i) & "Desc"
            Item.ListSubItems(1).Tag = Format$(i) & "DescToolTip"
            Item.SubItems(2) = Format$(i) & "Criteria"
            Item.ListSubItems(2).Tag = Format$(i) & "CriteriaToolTip"
            If Len(Trim$(Item.ListSubItems(2).Tag)) <> 0 Then
                Item.ListSubItems(1).ForeColor = &H6000
                Item.ListSubItems(2).ForeColor = &H6000
            End If
        Next i
    
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
        DestroyToolTip
    End Sub
    
    Private Sub lsvGoals_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        ShowToolTipForGoals X, Y
    End Sub
    
    Private Sub ShowToolTipForGoals(X As Single, Y As Single)
        Dim lvhti As LVHITTESTINFO
        Dim lItemIndex As Long
        Dim lSubItemIndex As Long
        Static lCurItemIndex As Long
        Static lCurSubItemIndex As Long
        '
        lvhti.pt.X = X / Screen.TwipsPerPixelX
        lvhti.pt.Y = Y / Screen.TwipsPerPixelY
        SendMessage lsvGoals.hWnd, LVM_SUBITEMHITTEST, 0, lvhti
        lItemIndex = lvhti.lItem + 1 ' In VB, the items are 1 based and in the API they are 0 based.
        lSubItemIndex = lvhti.lSubItem
        '
        If lCurItemIndex <> lItemIndex Or lCurSubItemIndex <> lSubItemIndex Then
            lCurItemIndex = lItemIndex
            lCurSubItemIndex = lSubItemIndex
            If lCurItemIndex = 0 Then  ' No item under the mouse pointer (or we don't wish to display).
                DestroyToolTip
            Else
                Select Case True
                Case lSubItemIndex = 1
                    CreateToolTip lsvGoals.hWnd, lsvGoals.ListItems(lItemIndex).ListSubItems(1).Tag, TTIconInfo, "Desc ToolTip", , , , True, , , 30000
                Case lSubItemIndex = 2
                    CreateToolTip lsvGoals.hWnd, lsvGoals.ListItems(lItemIndex).ListSubItems(2).Text, TTIconInfo, "Criteria ToolTip", , , , True, , , 60000
                Case Else
                    DestroyToolTip
                End Select
            End If
        End If
    End Sub
    
    Private Sub CreateToolTip(ByVal ParentHwnd As Long, _
                             ByVal TipText As String, _
                             Optional ByVal uIcon As ttIconType = TTNoIcon, _
                             Optional ByVal sTitle As String, _
                             Optional ByVal lForeColor As Long = -1, _
                             Optional ByVal lBackColor As Long = -1, _
                             Optional ByVal bCentered As Boolean, _
                             Optional ByVal bBalloon As Boolean, _
                             Optional ByVal lWrapTextLength As Long = 50, _
                             Optional ByVal lDelayTime As Long = 200, _
                             Optional ByVal lVisibleTime As Long = 5000)
        '
        ' If lWrapTextLength = 0 then there will be no wrap.
        ' Also, lWrapTextLength = 40 is a minimum value.
        ' The max for lVisibleTime is 32767.
        '
        Static bCommonControlsInitialized As Boolean
        Dim lWinStyle As Long
        Dim ti As TOOLINFO
        '
        If Not bCommonControlsInitialized Then
            InitCommonControls
            bCommonControlsInitialized = True
        End If
        '
        ' Destroy any previous tooltip.
        If hwndTT <> 0 Then DestroyWindow hwndTT
        '
        ' Format the text.
        FormatTooltipText TipText, lWrapTextLength
        '
        ' Initial style settings.
        lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
        If bBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON ' Create baloon style if desired.
        ' Set the style.
        hwndTT = CreateWindowEx(0&, TOOLTIPS_CLASSA, vbNullString, lWinStyle, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0&, 0&, App.hInstance, 0&)
        '
        ' Setup our tooltip info structure.
        ti.lFlags = TTF_SUBCLASS Or TTF_IDISHWND
        If bCentered Then ti.lFlags = ti.lFlags Or TTF_CENTERTIP
        ' Set the hwnd prop to our parent control's hwnd.
        ti.hWnd = ParentHwnd
        ti.lId = ParentHwnd
        ti.hInstance = App.hInstance
        ti.lpStr = TipText
        ti.lSize = LenB(ti)
        ' Set the tooltip structure
        SendMessage hwndTT, TTM_ADDTOOLA, 0&, ti
        SendMessage hwndTT, TTM_UPDATETIPTEXTA, 0&, ti
        '
        ' Colors.
        If lForeColor <> -1 Then SendMessage hwndTT, TTM_SETTIPTEXTCOLOR, lForeColor, 0&
        If lBackColor <> -1 Then SendMessage hwndTT, TTM_SETTIPBKCOLOR, lBackColor, 0&
        '
        ' Title or icon.
        If uIcon <> TTNoIcon Or sTitle <> vbNullString Then SendMessage hwndTT, TTM_SETTITLE, CLng(uIcon), ByVal sTitle
        '
        SendMessageLong hwndTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, lVisibleTime
        SendMessageLong hwndTT, TTM_SETDELAYTIME, TTDT_INITIAL, lDelayTime
    End Sub
    
    Private Sub DestroyToolTip()
        ' It's not a bad idea to put this in the Form_Unload event just to make sure.
        If hwndTT <> 0 Then DestroyWindow hwndTT
        hwndTT = 0
    End Sub
    
    Private Sub FormatTooltipText(TipText As String, lLen As Long)
        Dim s As String
        Dim i As Long
        '
        ' Make sure we need to do anything.
        If lLen = 0 Then Exit Sub
        If lLen < 40 Then lLen = 40
        If Len(TipText) <= lLen Then Exit Sub
        '
        Do
            i = InStrRev(TipText, " ", lLen + 1)
            If i = 0 Then
                s = s & Left$(TipText, lLen) & vbCrLf ' Build "s" and trim from TipText.
                TipText = Mid$(TipText, lLen + 1)
            Else
                s = s & Left$(TipText, i - 1) & vbCrLf ' Build "s" and trim from TipText.
                TipText = Mid$(TipText, i + 1)
            End If
            If Len(TipText) <= lLen Then
                TipText = s & TipText ' Place "s" back into TipText and get out.
                Exit Sub
            End If
        Loop
    End Sub
    
    Attached Files Attached Files
    Any software I post in these forums written by me is provided “AS IS” without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. Please understand that I’ve been programming since the mid-1970s and still have some of that code. My contemporary VB6 project is approaching 1,000 modules. In addition, I have a “VB6 random code folder” that is overflowing. I’ve been at this long enough to truly not know with absolute certainty from whence every single line of my code has come, with much of it coming from programmers under my employ who signed intellectual property transfers. I have not deliberately attempted to remove any licenses and/or attributions from any software. If someone finds that I have inadvertently done so, I sincerely apologize, and, upon notice and reasonable proof, will re-attach those licenses and/or attributions. To all, peace and happiness.

  4. #4

    Thread Starter
    Frenzied Member
    Join Date
    Mar 2005
    Location
    Italy-Napoli
    Posts
    1,742

    Re: EXCEL LISTVIEW AND Tooltips For Listitems In Listview

    Quote Originally Posted by Elroy View Post
    Here you go. I rather harshly ripped this out of a functioning project, but it's got all the pieces there.

    The Form1 code is as follows, but I've also attached it as a functioning VBP project. This functioning VBP project is a VB6 project, but these same ideas should work just fine in a VBA-32-bit project.

    Enjoy,
    Elroy

    Code:
    
    Option Explicit
    '
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
    Private Type RECT
        Left   As Long
        Top    As Long
        Right  As Long ' This is +1 (right - left = width)
        Bottom As Long ' This is +1 (bottom - top = height)
    End Type
    '
    Private Type LVHITTESTINFO
        pt As POINTAPI
        lFlags As Long
        lItem As Long
        lSubItem As Long
    End Type
    '
    Private Const LVM_FIRST              As Long = &H1000&
    Private Const LVM_GETNEXTITEM        As Long = (LVM_FIRST + 12&)
    Private Const LVM_HITTEST            As Long = (LVM_FIRST + 18&)
    Private Const LVM_SETITEMSTATE       As Long = (LVM_FIRST + 43&)
    Private Const LVM_SUBITEMHITTEST     As Long = (LVM_FIRST + 57&)
    '
    Private 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
    Private Declare Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '
    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
    '
    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 DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
    '
    Private Const WM_USER = &H400
    Private Const CW_USEDEFAULT = &H80000000
    '
    Private Const TTM_ACTIVATE = WM_USER + 1
    Private Const TTM_ADDTOOLA = WM_USER + 4
    Private Const TTM_SETDELAYTIME = WM_USER + 3
    Private Const TTM_UPDATETIPTEXTA = WM_USER + 12
    Private Const TTM_SETTIPBKCOLOR = WM_USER + 19
    Private Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
    Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
    Private Const TTM_SETTITLE = WM_USER + 32
    '
    Private Const TTS_NOPREFIX = &H2
    Private Const TTS_BALLOON = &H40
    Private Const TTS_ALWAYSTIP = &H1
    '
    Private Const TTF_CENTERTIP = &H2
    Private Const TTF_IDISHWND = &H1
    Private Const TTF_SUBCLASS = &H10
    Private Const TTF_TRANSPARENT = &H100
    '
    Private Const TTDT_AUTOPOP = 2
    Private Const TTDT_INITIAL = 3
    '
    Private Const TOOLTIPS_CLASSA = "tooltips_class32"
    '
    Public Enum ttIconType
        TTNoIcon = 0
        TTIconInfo = 1
        TTIconWarning = 2
        TTIconError = 3
    End Enum
    #If False Then ' Intellisense fix.
        Public TTNoIcon, TTIconInfo, TTIconWarning, TTIconError
    #End If
    '
    Private hwndTT As Long ' hwnd of the tooltip
    '
    
    Private Sub Form_Load()
        Dim i As Long
        Dim Item As ListItem
        '
        For i = 1 To 10
            Set Item = lsvGoals.ListItems.Add
            Item.Text = vbNullString
            Item.SubItems(1) = Format$(i) & "Desc"
            Item.ListSubItems(1).Tag = Format$(i) & "DescToolTip"
            Item.SubItems(2) = Format$(i) & "Criteria"
            Item.ListSubItems(2).Tag = Format$(i) & "CriteriaToolTip"
            If Len(Trim$(Item.ListSubItems(2).Tag)) <> 0 Then
                Item.ListSubItems(1).ForeColor = &H6000
                Item.ListSubItems(2).ForeColor = &H6000
            End If
        Next i
    
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
        DestroyToolTip
    End Sub
    
    Private Sub lsvGoals_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        ShowToolTipForGoals X, Y
    End Sub
    
    Private Sub ShowToolTipForGoals(X As Single, Y As Single)
        Dim lvhti As LVHITTESTINFO
        Dim lItemIndex As Long
        Dim lSubItemIndex As Long
        Static lCurItemIndex As Long
        Static lCurSubItemIndex As Long
        '
        lvhti.pt.X = X / Screen.TwipsPerPixelX
        lvhti.pt.Y = Y / Screen.TwipsPerPixelY
        SendMessage lsvGoals.hWnd, LVM_SUBITEMHITTEST, 0, lvhti
        lItemIndex = lvhti.lItem + 1 ' In VB, the items are 1 based and in the API they are 0 based.
        lSubItemIndex = lvhti.lSubItem
        '
        If lCurItemIndex <> lItemIndex Or lCurSubItemIndex <> lSubItemIndex Then
            lCurItemIndex = lItemIndex
            lCurSubItemIndex = lSubItemIndex
            If lCurItemIndex = 0 Then  ' No item under the mouse pointer (or we don't wish to display).
                DestroyToolTip
            Else
                Select Case True
                Case lSubItemIndex = 1
                    CreateToolTip lsvGoals.hWnd, lsvGoals.ListItems(lItemIndex).ListSubItems(1).Tag, TTIconInfo, "Desc ToolTip", , , , True, , , 30000
                Case lSubItemIndex = 2
                    CreateToolTip lsvGoals.hWnd, lsvGoals.ListItems(lItemIndex).ListSubItems(2).Text, TTIconInfo, "Criteria ToolTip", , , , True, , , 60000
                Case Else
                    DestroyToolTip
                End Select
            End If
        End If
    End Sub
    
    Private Sub CreateToolTip(ByVal ParentHwnd As Long, _
                             ByVal TipText As String, _
                             Optional ByVal uIcon As ttIconType = TTNoIcon, _
                             Optional ByVal sTitle As String, _
                             Optional ByVal lForeColor As Long = -1, _
                             Optional ByVal lBackColor As Long = -1, _
                             Optional ByVal bCentered As Boolean, _
                             Optional ByVal bBalloon As Boolean, _
                             Optional ByVal lWrapTextLength As Long = 50, _
                             Optional ByVal lDelayTime As Long = 200, _
                             Optional ByVal lVisibleTime As Long = 5000)
        '
        ' If lWrapTextLength = 0 then there will be no wrap.
        ' Also, lWrapTextLength = 40 is a minimum value.
        ' The max for lVisibleTime is 32767.
        '
        Static bCommonControlsInitialized As Boolean
        Dim lWinStyle As Long
        Dim ti As TOOLINFO
        '
        If Not bCommonControlsInitialized Then
            InitCommonControls
            bCommonControlsInitialized = True
        End If
        '
        ' Destroy any previous tooltip.
        If hwndTT <> 0 Then DestroyWindow hwndTT
        '
        ' Format the text.
        FormatTooltipText TipText, lWrapTextLength
        '
        ' Initial style settings.
        lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
        If bBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON ' Create baloon style if desired.
        ' Set the style.
        hwndTT = CreateWindowEx(0&, TOOLTIPS_CLASSA, vbNullString, lWinStyle, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0&, 0&, App.hInstance, 0&)
        '
        ' Setup our tooltip info structure.
        ti.lFlags = TTF_SUBCLASS Or TTF_IDISHWND
        If bCentered Then ti.lFlags = ti.lFlags Or TTF_CENTERTIP
        ' Set the hwnd prop to our parent control's hwnd.
        ti.hWnd = ParentHwnd
        ti.lId = ParentHwnd
        ti.hInstance = App.hInstance
        ti.lpStr = TipText
        ti.lSize = LenB(ti)
        ' Set the tooltip structure
        SendMessage hwndTT, TTM_ADDTOOLA, 0&, ti
        SendMessage hwndTT, TTM_UPDATETIPTEXTA, 0&, ti
        '
        ' Colors.
        If lForeColor <> -1 Then SendMessage hwndTT, TTM_SETTIPTEXTCOLOR, lForeColor, 0&
        If lBackColor <> -1 Then SendMessage hwndTT, TTM_SETTIPBKCOLOR, lBackColor, 0&
        '
        ' Title or icon.
        If uIcon <> TTNoIcon Or sTitle <> vbNullString Then SendMessage hwndTT, TTM_SETTITLE, CLng(uIcon), ByVal sTitle
        '
        SendMessageLong hwndTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, lVisibleTime
        SendMessageLong hwndTT, TTM_SETDELAYTIME, TTDT_INITIAL, lDelayTime
    End Sub
    
    Private Sub DestroyToolTip()
        ' It's not a bad idea to put this in the Form_Unload event just to make sure.
        If hwndTT <> 0 Then DestroyWindow hwndTT
        hwndTT = 0
    End Sub
    
    Private Sub FormatTooltipText(TipText As String, lLen As Long)
        Dim s As String
        Dim i As Long
        '
        ' Make sure we need to do anything.
        If lLen = 0 Then Exit Sub
        If lLen < 40 Then lLen = 40
        If Len(TipText) <= lLen Then Exit Sub
        '
        Do
            i = InStrRev(TipText, " ", lLen + 1)
            If i = 0 Then
                s = s & Left$(TipText, lLen) & vbCrLf ' Build "s" and trim from TipText.
                TipText = Mid$(TipText, lLen + 1)
            Else
                s = s & Left$(TipText, i - 1) & vbCrLf ' Build "s" and trim from TipText.
                TipText = Mid$(TipText, i + 1)
            End If
            If Len(TipText) <= lLen Then
                TipText = s & TipText ' Place "s" back into TipText and get out.
                Exit Sub
            End If
        Loop
    End Sub
    
    excellent!

    In vb6 in other case work fine.

    ops....
    in VBA for excel mouse_Move in listview have:
    MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)


    instead in vb6 _Move in listview have ;
    MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Last edited by luca90; May 2nd, 2018 at 03:53 PM.

  5. #5

    Thread Starter
    Frenzied Member
    Join Date
    Mar 2005
    Location
    Italy-Napoli
    Posts
    1,742

    Re: EXCEL LISTVIEW AND Tooltips For Listitems In Listview

    Quote Originally Posted by Elroy View Post
    Here you go. I rather harshly ripped this out of a functioning project, but it's got all the pieces there.

    The Form1 code is as follows, but I've also attached it as a functioning VBP project. This functioning VBP project is a VB6 project, but these same ideas should work just fine in a VBA-32-bit project.

    Enjoy,
    Elroy

    Code:
    
    Option Explicit
    '
    Private Type POINTAPI
        X As Long
        Y As Long
    End Type
    Private Type RECT
        Left   As Long
        Top    As Long
        Right  As Long ' This is +1 (right - left = width)
        Bottom As Long ' This is +1 (bottom - top = height)
    End Type
    '
    Private Type LVHITTESTINFO
        pt As POINTAPI
        lFlags As Long
        lItem As Long
        lSubItem As Long
    End Type
    '
    Private Const LVM_FIRST              As Long = &H1000&
    Private Const LVM_GETNEXTITEM        As Long = (LVM_FIRST + 12&)
    Private Const LVM_HITTEST            As Long = (LVM_FIRST + 18&)
    Private Const LVM_SETITEMSTATE       As Long = (LVM_FIRST + 43&)
    Private Const LVM_SUBITEMHITTEST     As Long = (LVM_FIRST + 57&)
    '
    Private 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
    Private Declare Function SendMessageLong Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    '
    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
    '
    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 DestroyWindow Lib "user32" (ByVal hWnd As Long) As Long
    '
    Private Const WM_USER = &H400
    Private Const CW_USEDEFAULT = &H80000000
    '
    Private Const TTM_ACTIVATE = WM_USER + 1
    Private Const TTM_ADDTOOLA = WM_USER + 4
    Private Const TTM_SETDELAYTIME = WM_USER + 3
    Private Const TTM_UPDATETIPTEXTA = WM_USER + 12
    Private Const TTM_SETTIPBKCOLOR = WM_USER + 19
    Private Const TTM_SETTIPTEXTCOLOR = WM_USER + 20
    Private Const TTM_SETMAXTIPWIDTH = WM_USER + 24
    Private Const TTM_SETTITLE = WM_USER + 32
    '
    Private Const TTS_NOPREFIX = &H2
    Private Const TTS_BALLOON = &H40
    Private Const TTS_ALWAYSTIP = &H1
    '
    Private Const TTF_CENTERTIP = &H2
    Private Const TTF_IDISHWND = &H1
    Private Const TTF_SUBCLASS = &H10
    Private Const TTF_TRANSPARENT = &H100
    '
    Private Const TTDT_AUTOPOP = 2
    Private Const TTDT_INITIAL = 3
    '
    Private Const TOOLTIPS_CLASSA = "tooltips_class32"
    '
    Public Enum ttIconType
        TTNoIcon = 0
        TTIconInfo = 1
        TTIconWarning = 2
        TTIconError = 3
    End Enum
    #If False Then ' Intellisense fix.
        Public TTNoIcon, TTIconInfo, TTIconWarning, TTIconError
    #End If
    '
    Private hwndTT As Long ' hwnd of the tooltip
    '
    
    Private Sub Form_Load()
        Dim i As Long
        Dim Item As ListItem
        '
        For i = 1 To 10
            Set Item = lsvGoals.ListItems.Add
            Item.Text = vbNullString
            Item.SubItems(1) = Format$(i) & "Desc"
            Item.ListSubItems(1).Tag = Format$(i) & "DescToolTip"
            Item.SubItems(2) = Format$(i) & "Criteria"
            Item.ListSubItems(2).Tag = Format$(i) & "CriteriaToolTip"
            If Len(Trim$(Item.ListSubItems(2).Tag)) <> 0 Then
                Item.ListSubItems(1).ForeColor = &H6000
                Item.ListSubItems(2).ForeColor = &H6000
            End If
        Next i
    
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
        DestroyToolTip
    End Sub
    
    Private Sub lsvGoals_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        ShowToolTipForGoals X, Y
    End Sub
    
    Private Sub ShowToolTipForGoals(X As Single, Y As Single)
        Dim lvhti As LVHITTESTINFO
        Dim lItemIndex As Long
        Dim lSubItemIndex As Long
        Static lCurItemIndex As Long
        Static lCurSubItemIndex As Long
        '
        lvhti.pt.X = X / Screen.TwipsPerPixelX
        lvhti.pt.Y = Y / Screen.TwipsPerPixelY
        SendMessage lsvGoals.hWnd, LVM_SUBITEMHITTEST, 0, lvhti
        lItemIndex = lvhti.lItem + 1 ' In VB, the items are 1 based and in the API they are 0 based.
        lSubItemIndex = lvhti.lSubItem
        '
        If lCurItemIndex <> lItemIndex Or lCurSubItemIndex <> lSubItemIndex Then
            lCurItemIndex = lItemIndex
            lCurSubItemIndex = lSubItemIndex
            If lCurItemIndex = 0 Then  ' No item under the mouse pointer (or we don't wish to display).
                DestroyToolTip
            Else
                Select Case True
                Case lSubItemIndex = 1
                    CreateToolTip lsvGoals.hWnd, lsvGoals.ListItems(lItemIndex).ListSubItems(1).Tag, TTIconInfo, "Desc ToolTip", , , , True, , , 30000
                Case lSubItemIndex = 2
                    CreateToolTip lsvGoals.hWnd, lsvGoals.ListItems(lItemIndex).ListSubItems(2).Text, TTIconInfo, "Criteria ToolTip", , , , True, , , 60000
                Case Else
                    DestroyToolTip
                End Select
            End If
        End If
    End Sub
    
    Private Sub CreateToolTip(ByVal ParentHwnd As Long, _
                             ByVal TipText As String, _
                             Optional ByVal uIcon As ttIconType = TTNoIcon, _
                             Optional ByVal sTitle As String, _
                             Optional ByVal lForeColor As Long = -1, _
                             Optional ByVal lBackColor As Long = -1, _
                             Optional ByVal bCentered As Boolean, _
                             Optional ByVal bBalloon As Boolean, _
                             Optional ByVal lWrapTextLength As Long = 50, _
                             Optional ByVal lDelayTime As Long = 200, _
                             Optional ByVal lVisibleTime As Long = 5000)
        '
        ' If lWrapTextLength = 0 then there will be no wrap.
        ' Also, lWrapTextLength = 40 is a minimum value.
        ' The max for lVisibleTime is 32767.
        '
        Static bCommonControlsInitialized As Boolean
        Dim lWinStyle As Long
        Dim ti As TOOLINFO
        '
        If Not bCommonControlsInitialized Then
            InitCommonControls
            bCommonControlsInitialized = True
        End If
        '
        ' Destroy any previous tooltip.
        If hwndTT <> 0 Then DestroyWindow hwndTT
        '
        ' Format the text.
        FormatTooltipText TipText, lWrapTextLength
        '
        ' Initial style settings.
        lWinStyle = TTS_ALWAYSTIP Or TTS_NOPREFIX
        If bBalloon Then lWinStyle = lWinStyle Or TTS_BALLOON ' Create baloon style if desired.
        ' Set the style.
        hwndTT = CreateWindowEx(0&, TOOLTIPS_CLASSA, vbNullString, lWinStyle, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, 0&, 0&, App.hInstance, 0&)
        '
        ' Setup our tooltip info structure.
        ti.lFlags = TTF_SUBCLASS Or TTF_IDISHWND
        If bCentered Then ti.lFlags = ti.lFlags Or TTF_CENTERTIP
        ' Set the hwnd prop to our parent control's hwnd.
        ti.hWnd = ParentHwnd
        ti.lId = ParentHwnd
        ti.hInstance = App.hInstance
        ti.lpStr = TipText
        ti.lSize = LenB(ti)
        ' Set the tooltip structure
        SendMessage hwndTT, TTM_ADDTOOLA, 0&, ti
        SendMessage hwndTT, TTM_UPDATETIPTEXTA, 0&, ti
        '
        ' Colors.
        If lForeColor <> -1 Then SendMessage hwndTT, TTM_SETTIPTEXTCOLOR, lForeColor, 0&
        If lBackColor <> -1 Then SendMessage hwndTT, TTM_SETTIPBKCOLOR, lBackColor, 0&
        '
        ' Title or icon.
        If uIcon <> TTNoIcon Or sTitle <> vbNullString Then SendMessage hwndTT, TTM_SETTITLE, CLng(uIcon), ByVal sTitle
        '
        SendMessageLong hwndTT, TTM_SETDELAYTIME, TTDT_AUTOPOP, lVisibleTime
        SendMessageLong hwndTT, TTM_SETDELAYTIME, TTDT_INITIAL, lDelayTime
    End Sub
    
    Private Sub DestroyToolTip()
        ' It's not a bad idea to put this in the Form_Unload event just to make sure.
        If hwndTT <> 0 Then DestroyWindow hwndTT
        hwndTT = 0
    End Sub
    
    Private Sub FormatTooltipText(TipText As String, lLen As Long)
        Dim s As String
        Dim i As Long
        '
        ' Make sure we need to do anything.
        If lLen = 0 Then Exit Sub
        If lLen < 40 Then lLen = 40
        If Len(TipText) <= lLen Then Exit Sub
        '
        Do
            i = InStrRev(TipText, " ", lLen + 1)
            If i = 0 Then
                s = s & Left$(TipText, lLen) & vbCrLf ' Build "s" and trim from TipText.
                TipText = Mid$(TipText, lLen + 1)
            Else
                s = s & Left$(TipText, i - 1) & vbCrLf ' Build "s" and trim from TipText.
                TipText = Mid$(TipText, i + 1)
            End If
            If Len(TipText) <= lLen Then
                TipText = s & TipText ' Place "s" back into TipText and get out.
                Exit Sub
            End If
        Loop
    End Sub
    
    excellent!

    In vb6 in other case work fine.

    EXPERIMENT ATTACHED

    ops....
    in VBA for excel mouse_Move in listview have:
    MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)


    instead in vb6 _Move in listview have ;
    MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Attached Files Attached Files
    Last edited by luca90; May 6th, 2018 at 10:00 AM.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Featured


Click Here to Expand Forum to Full Width