1 ''' // **************************************
   2 ''' // User Form code
   3 ''' // **************************************
   4 
   5 ''' // Windows API Function required
   6 Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
   7                                         (ByVal hwnd As Long, _
   8                                          ByVal wMsg As Long, _
   9                                          ByVal wParam As Long, _
  10                                          lParam As Any) As Long
  11 
  12 Const LVM_FIRST = &H1000&
  13 Const LVM_HITTEST = LVM_FIRST + 18
  14 Const LVM_SUBITEMHITTEST = LVM_FIRST + 57
  15 Const LVHT_ONITEMICON As Long = &H2
  16 Const LVHT_ONITEMLABEL As Long = &H4
  17 Const LVHT_ONITEMSTATEICON As Long = &H8
  18 Const LVHT_ONITEM As Long = (LVHT_ONITEMICON Or _
  19                                                      LVHT_ONITEMLABEL Or _
  20                                                      LVHT_ONITEMSTATEICON)
  21 
  22 
  23 Private Type POINTAPI
  24     x As Long
  25     y As Long
  26 End Type
  27 
  28 Private Type LVHITTESTINFO
  29    pt As POINTAPI
  30    flags As Long
  31    iItem As Long
  32    iSubItem As Long
  33 End Type
  34 
  35 ''' // Initialize Tooltip Class
  36 Dim TT As cToolTip
  37 Dim m_lCurItemIndex As Long
  38 
  39 Dim m_HdrHwnd As Long
  40 
  41 
  42 
  43 ''' // Initialize User Form and Tooltip Class
  44 Private Sub UserForm_Initialize()
  45     Set TT = New cToolTip
  46     TT.Style = TTBalloon
  47     TT.Icon = TTIconInfo
  48 End Sub
  49 
  50 Private Sub UserForm_Terminate()
  51     TT.Destroy
  52     Set TT = Nothing
  53 End Sub
  54 
  55 
  56 ''' // Get the mouse moves over the ListView
  57 Private Sub ListView1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
  58 Dim lvhti As LVHITTESTINFO
  59 Dim lItemIndex As Long
  60 Dim colIndex As Long
  61 Dim sListItemValue As String
  62 
  63    lvhti.pt.x = x '/ Screen.TwipsPerPixelX
  64    lvhti.pt.y = y '/ Screen.TwipsPerPixelY
  65    lvhti.flags = LVHT_ONITEM
  66 
  67    ''' // Determine the ListItem the mouse cursor is above currently
  68    lItemIndex = SendMessage(ListView1.hwnd, LVM_HITTEST, 0, lvhti) + 1
  69    ''' // Determine the column of the ListView
  70    colIndex = SendMessage(ListView1.hwnd, LVM_SUBITEMHITTEST, -1, lvhti) + 1
  71    colIndex = lvhti.iSubItem
  72 
  73    If m_lCurItemIndex <> lItemIndex Then
  74       m_lCurItemIndex = lItemIndex
  75       If m_lCurItemIndex = 0 Then   ' no item under the mouse pointer
  76          TT.Destroy
  77       Else
  78         ''' // Depending on the column index, determine the tooltip to show
  79         If colIndex = 0 Then
  80             TT.Title = "Product Details:"
  81             sListItemValue = ListView1.ListItems(m_lCurItemIndex).Text
  82             If sListItemValue = "" Then
  83                 TT.Destroy
  84                 Exit Sub
  85             End If
  86             TT.TipText = ProductDetails_Get(sListItemValue)
  87         ElseIf colIndex = 1 Then
  88             TT.Title = "Customer Details:"
  89             sListItemValue = ListView1.ListItems(m_lCurItemIndex).ListSubItems(1).Text
  90             If sListItemValue = "" Then
  91                 TT.Destroy
  92                 Exit Sub
  93             End If
  94             TT.TipText = CustomerDetails_Get(sListItemValue)
  95         Else
  96             TT.Destroy
  97             Exit Sub
  98         End If
  99 
 100         TT.Create ListView1.hwnd
 101       End If
 102    End If
 103 
 104 End Sub
 105 
 106 ''' // Get Tooltip for Products
 107 Function ProductDetails_Get(sProductID As String) As String
 108 Dim WS As Worksheet
 109 Dim lr As Long
 110 Dim r As Long
 111 Dim sString As String
 112 Dim activeWS As Worksheet
 113 
 114     Set activeWS = ActiveSheet  ''' // Remember the currently active WS
 115 
 116     Set WS = ThisWorkbook.Worksheets("DemoData")    ''' // Active the WS containing the data - without activating it we cannot use Find in order to lookup data
 117     WS.Activate
 118     lr = Tools.Get_Last_Row(WS)
 119     On Error Resume Next
 120     r = WS.Range(Cells(2, 1), Cells(lr, 1)).Find(sProductID).Row
 121     If Err.Number = 91 Then
 122         ProductDetails_Get = ""
 123     Else
 124         sString = "Product ID: " & sProductID & vbCrLf
 125         sString = sString & "Product Name: " & WS.Cells(r, 2).Value
 126         ProductDetails_Get = sString
 127     End If
 128     On Error GoTo 0
 129     activeWS.Activate   ''' // Activate previous WS again
 130 End Function
 131 
 132 ''' // Get Tooltip for Customers
 133 Function CustomerDetails_Get(sCustomerID As String) As String
 134 Dim WS As Worksheet
 135 Dim lr As Long
 136 Dim r As Long
 137 Dim sString As String
 138 Dim activeWS As Worksheet
 139 
 140     Set activeWS = ActiveSheet
 141 
 142     Set WS = ThisWorkbook.Worksheets("DemoData")
 143     WS.Activate
 144     lr = Tools.Get_Last_Row(WS)
 145     On Error Resume Next
 146     r = WS.Range(Cells(2, 4), Cells(lr, 4)).Find(sCustomerID).Row
 147     If Err.Number = 91 Then
 148         CustomerDetails_Get = ""
 149     Else
 150         sString = "Customer ID: " & sCustomerID & vbCrLf
 151         sString = sString & "Customer Name: " & WS.Cells(r, 5).Value
 152         CustomerDetails_Get = sString
 153     End If
 154     On Error GoTo 0
 155     activeWS.Activate
 156 End Function
 157 
 158 ''' // Close
 159 Private Sub CommandButton1_Click()
 160     Unload Me
 161 End Sub
 162