Hi,
Maybe you should look into the ListView control which is available since win
2k to any user (installed with Windows).
This control is much more flexible that the regular Listbox:
- you can add icons to each row
- you can add column headers that respond to CLick events
- you can have your user resize the columns
- you can sort the list alphabetically based on a specific column
- (...)
- AND IT HAS A ITEM_CLICK event
To show this control in the Toolbox toolbar of the vba editor:
- add a reference to
Microsoft Windows Commom Controls 6.0 (SP4 or 6)
or browse to C:\Winnt\system32\mscomctl.ocx if the ref is not already in
the list
( or C:\Winnt\system32\mscomctl32.ocx if older version)
- right-click the Toolbox page name and add a new page
- on that new page, right click to add a control and add 'Microsoft Listview
Control' with the latest version.
Now add one ListView Control to a Userform and call it Lvw
''' #### Userform with 1 Listview control: Lvw
''' ############################################
Private Sub UserForm_Initialize()
With Lvw
.View = lvwReport ''' view as listbox
.AllowColumnReorder = False ''' prevent crashing xl sometimes
''' add columns and headers
.ColumnHeaders.Add 1, "h1", "Header1", 50
.ColumnHeaders.Add 2, "h2", "Header2", 50
.ColumnHeaders.Add 3, "h3", "Header3", 50
''' add row 1
With .ListItems.Add(1, "k11", "Item r1_c1")
.ListSubItems.Add 1, "k12", "Item r1_c2"
.ListSubItems.Add 2, "k13", "Item r1_c3"
End With
''' add row 2
With .ListItems.Add(2, "k21", "Item r2_c1")
.ListSubItems.Add 1, "k22", "Item r2_c2"
.ListSubItems.Add 2, "k23", "Item r2_c3"
End With
End With
End Sub
Private Sub Lvw_ItemClick(ByVal Item As MSComctlLib.ListItem)
MsgBox "Item " & Item.Index & " was clicked"
End Sub
''' ############################################
This may not be enough to track an item based on Mouse_down or Mouse_Up
event, so here is some new code that uses apis to track the item (column 1)
and subitems (columns 2,3,...) bellow the mouse pointer.
Clear the Userform module and paste the following code. It reacts to
mouse_down, but same idea for mouse_up.
''' ############################################
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal lMsg As Long, ByVal wParam As Long, _
lParam As Any) As Long
Private Const LVM_FIRST = &H1000
Private Const LVM_DELETEALLITEMS = (LVM_FIRST + 9)
Private Const LVM_GETITEMRECT = (LVM_FIRST + 14)
Private Const LVM_HITTEST = (LVM_FIRST + 18)
Private Const LVM_SUBITEMHITTEST = (LVM_FIRST + 57)
Private Const LVM_GETCOLUMNWIDTH = (LVM_FIRST + 29)
Private Const LVM_GETVIEWRECT = (LVM_FIRST + 34)
Private Const LVM_GETTOPINDEX = (LVM_FIRST + 39)
Private Const LVM_GETCOUNTPERPAGE = (LVM_FIRST + 40)
Private Const LVM_GETSUBITEMRECT = (LVM_FIRST + 56)
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type LVHITTESTINFO
pt As POINTAPI
lFlags As Long
lItem As Long
lSubItem As Long
End Type
Private Sub UserForm_Initialize()
With Lvw
.View = lvwReport ''' view as listbox
.AllowColumnReorder = False ''' prevent crashing xl sometimes
''' add columns and headers
.ColumnHeaders.Add 1, "h1", "Header1", 50
.ColumnHeaders.Add 2, "h2", "Header2", 50
.ColumnHeaders.Add 3, "h3", "Header3", 50
''' add row 1
With .ListItems.Add(1, "k11", "Item r1_c1")
.ListSubItems.Add 1, "k12", "Item r1_c2"
.ListSubItems.Add 2, "k13", "Item r1_c3"
End With
''' add row 2
With .ListItems.Add(2, "k21", "Item r2_c1")
.ListSubItems.Add 1, "k22", "Item r2_c2"
.ListSubItems.Add 2, "k23", "Item r2_c3"
End With
End With
End Sub
Private Sub lvw_MouseDown(ByVal Button As Integer, ByVal Shift As Integer,
ByVal X As stdole.OLE_XPOS_PIXELS, ByVal Y As stdole.OLE_YPOS_PIXELS)
Dim THT As LVHITTESTINFO
Dim LSI As ListSubItem
Dim LI As ListItem
HitTest X, Y, THT
If THT.lSubItem > 0 And THT.lItem >= 0 Then ''' SubItem Column
Set LI = Lvw.ListItems(THT.lItem + 1)
Set LSI = Lvw.ListItems(THT.lItem + 1).ListSubItems(THT.lSubItem)
MsgBox "List Item: " & LI.Index & " - List Subitem:" & LSI.Index
ElseIf THT.lSubItem = 0 And THT.lItem >= 0 Then ''' ITEM column
Set LI = Lvw.ListItems(THT.lItem + 1)
Set LSI = Nothing
MsgBox "List Item: " & LI.Index & " - No Subitem clicked"
Else
MsgBox "No item clicked"
End If
End Sub
Private Sub HitTest(ByVal X As Single, ByVal Y As Single, tHitTest As
LVHITTESTINFO)
Dim lRet As Long
Dim lX As Long
Dim lY As Long
' x and y are in twips; convert them to pixels for the API call
lX = X '/ Screen.TwipsPerPixelX
lY = Y '/ Screen.TwipsPerPixelY
With tHitTest
.lFlags = 0
.lItem = 0
.lSubItem = 0
.pt.X = lX
.pt.Y = lY
End With
lRet = SendMessage(Lvw.hwnd, LVM_SUBITEMHITTEST, 0, tHitTest)
End Sub
''' ###########################################
