File 1, Form1.frm
Add a listview, two imagelist, a text box
The code is as follows: OPTION Explicit '' Copyright? 1997-1999 Brad Martinez, http://www.mvps.org '' Demonstrate How To in Place Do Subitem Editing In The VB ListView.
Private m_hwndLV As Long 'ListView1.hWndPrivate m_hwndTB As Long' TextBox1.hWndPrivate m_iItem As Long 'ListItem.Index whose SubItem is being editedPrivate m_iSubItem As Long' zero based index of ListView1.ListItems (m_iItem) .SubItem being edited '
Private Sub Form_Load () Dim i As Long Dim item As ListItem 'Text1.Appearance = ccFlat' ComctlLib enum value Text1.Visible = False m_hwndTB = Text1.hWnd 'Initialize the ImageLists With ImageList1 .ImageHeight = 32 .ImageWidth = 32 .ListImages. Add Picture: = Icon End With With ImageList2 .ImageHeight = 16 .ImageWidth = 16 .ListImages.Add Picture: = Icon End With 'Initialize the ListView With ListView1' .LabelEdit = lvwManual .HideSelection = False .Icons = ImageList1 .SmallIcons = ImageList2 m_hwndlv = .hWnd for i = 1 to 4 .columnheaders.add text: = "column" & i next for i = 0 to & h3f set item = .listitems.add (, "Item" & I, 1, 1) Item .SUBITEMS (1) = i * 10 item.subItems (2) = i * 100 item.subItems (3) = i * 1000 Next End with end sub
PRIVATE SUB FORM_RESize () 'ListView1.move 0, 0, Scalewidth, ScaleHeightend Sub
Private Sub ListView1_DblClick () Dim lvhti As LVHITTESTINFO Dim rc As RECT Dim li As ListItem 'If a left button double-click ... (change to suit) If (GetKeyState (vbKeyLButton) And & H8000) Then' If a ListView SubItem is double clicked ... Call GetCursorPos (lvhti.pt) Call ScreenToClient (m_hwndLV, lvhti.pt) If (ListView_SubItemHitTest (m_hwndLV, lvhti) <> LVI_NOITEM) Then If lvhti.iSubItem Then 'Get the SubItem's label (and icon) rect. If ListView_GetSubItemRect (m_hwndLV, lvhti.iItem, lvhti.iSubItem, LVIR_LABEL, rc) Then 'Either set the ListView as the TextBox parent window in order to' have the TextBox Move method use ListView client coords, or just 'map the ListView client coords to The TextBox's PAENT FORM 'CALL setParent (m_hwndtb, m_hwndlv) Call MapWindowPoints (M_HWndlv, Hwnd, RC, 2) Text1.move (rc.left 4) * Screen.twipsPerpixelx, _ rc.top * Screen.TwipsPerPixelY, _ (rc.Right - rc.Left) * Screen.TwipsPerPixelX, _ (rc.Bottom - rc.Top) * Screen.TwipsPerPixelY 'Save the one-based index of the ListItem and the zero-based index 'of the SubItem (if the ListView is sorted via the API, then ListItem.Index' will be different than lvhti.iItem 1 ...) m_iItem = lvhti.iItem 1 m_iSubItem = lvhti.iSubItem 'Put the SubItem's text in The TextBox, Save the Subitem's text, 'and clear the subitem's text. Text1 =
ListView1.ListItems (m_iItem) .SubItems (m_iSubItem) Text1.Tag = Text1 ListView1.ListItems (m_iItem) .SubItems (m_iSubItem) = "" 'Make the TextBox the topmost Form control, make the it visible, select' its text, give it the focus, and subclass it. Text1.ZOrder 0 Text1.Visible = True Text1.SelStart = 0 Text1.SelLength = Len (Text1) Text1.SetFocus Call subClass (m_hwndTB, AddressOf WndProc) End If 'ListView_GetSubItemRect End If' lvhti. ISUBITEM END IF 'LISTVIEW_SUBITEMHITEST END IF' GETKEYSTATE (VBKEYLBUTTON) End Sub 'Selects The ListItem whose SubItem is Being Edited ...
PRIVATE SUB TEXT1_GOTFOCUS () listview1.listitems (m_iitem) .selected = trueEnd Sub
'Ness.
Private sub text1_change () if m_iitem the text1.width = textwidth (Text1) 180END SUB
'Update The Subitem Text on The Enter Key, Cancel on The Escape Key.
Private Sub Text1_KeyPress (KeyAscii As Integer) If (KeyAscii = vbKeyReturn) Then Call HideTextBox (True) KeyAscii = 0 ElseIf (KeyAscii = vbKeyEscape) Then Call HideTextBox (False) KeyAscii = 0 End If
End Sub
Friend Sub HideTextBox (fApplyChanges As Boolean) If fApplyChanges Then ListView1.ListItems (m_iItem) .SubItems (m_iSubItem) = Text1 Else ListView1.ListItems (m_iItem) .SubItems (m_iSubItem) = Text1.Tag End If Call UnSubClass (m_hwndTB) Text1.Visible = False text1 = "" 'Call setParent (m_hwndtb, hwnd)' listview1.setfocus m_iitem = 0 End Sub file 2: module1.bas
OPTION EXPLICIT '' COPYRIGHT? 1997-1999 Brad Martinez, http://www.mvps.org'public Type Pointapi 'Pt x as long y as longend type
PUBLIC TYPE RECT 'RCT LEFT AS Long Top As Long Right As Long Bottom As Longend Type
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongDeclare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As LongDeclare Function GetKeyState Lib "user32" (ByVal nVirtKey As KeyCodeConstants) As Integer
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As LongDeclare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As Long, ByVal hwndTo As Long, lppt As Any, ByVal cPoints As Long) As Long
Declare function sendMessage Lib "User32" Alias "SendMessagea" _ (Byval HWnd As Long, _ Byval WParam as long, _ lparam as any) as long '<---
'==================================================== ============================================================================================
'user-definedpublic const lvi_noitem = -1
'MessageSpublic constlvm_first = & h1000 # ix (win32_ie> = & h300) Thenpublic constliic_getsubItemRect = (LVM_First 56) Public const lvm_subitemhittest = (LVM_First 57) #END IF
'LVM_GETSUBITEMRECT RCT.LEFTPUBLIC ConST LVIR_ICON = 1PUBLIC Const Lvir_Label = 2
Public Type LVHITTESTINFO 'was LV_HITTESTINFO pt As POINTAPI flags As Long iItem As Long # If (WIN32_IE> = & H300) Then iSubItem As Long' this is was NOT in win95. Valid only for LVM_SUBITEMHITTEST # End IfEnd Type
'Lvhitteinfo flagspublic const lvht_onitemlabel = & h4'
#If (Win32_ie> = & H300) THEN
Public Function ListView_GetSubItemRect (hWnd As Long, iItem As Long, iSubItem As Long, _ code As Long, prc As RECT) As Boolean prc.Top = iSubItem prc.Left = code ListView_GetSubItemRect = SendMessage (hWnd, LVM_GETSUBITEMRECT, ByVal iItem, prc) END FUNCTION
Public Function ListView_SubiteMhittest (HWND As Long, Plvhti As Lvhittestinfo) As long listview_subitemhittest = sendMessage (hwnd, lvm_subitemhittest, 0, plvhti) End Function
#Endiff '' Win32_ie> = & H300
File three: msubclass.bas
Option Explicit '' Copyright 1997-1999 Brad Martinez, http:? //Www.mvps.org'Private Const WM_DESTROY = & H2Private Const WM_KILLFOCUS = & H8Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As LongPrivate Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As LongPrivate Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long , BYVAL LPSTRING AS STRING) AS Long
Declare function setwindowlong lib "user32" alias "setwindowlonga" (byval nindex as long, byval dwnewlong as long) As longprivate const gwl_wndproc = (-4)
Private Declare Function CallWindowProc Lib "User32" Alias "CallWindowProca" (Byval HwndowProca "(Byval Hwnd As Long, Byval Umsg As Long, Byval WParam As long) As long
Private constondWndproc = "oldwndproc" '
Public Function SubClass (hWnd As Long, lpfnNew As Long) As Boolean Dim lpfnOld As Long Dim fSuccess As Boolean If (GetProp (hWnd, OLDWNDPROC) = 0) Then lpfnOld = SetWindowLong (hWnd, GWL_WNDPROC, lpfnNew) If lpfnOld Then fSuccess = SetProp (hWnd, OLDWNDPROC, lpfnOld) End If End If If fSuccess Then subClass = True Else If lpfnOld Then Call unSubClass (hWnd) MsgBox "Unable to successfully subclass & H" & Hex (hWnd), vbCritical End If End Function
Public Function UnSubClass (hWnd As Long) As Boolean Dim lpfnOld As Long lpfnOld = GetProp (hWnd, OLDWNDPROC) If lpfnOld Then If RemoveProp (hWnd, OLDWNDPROC) Then UnSubClass = SetWindowLong (hWnd, GWL_WNDPROC, lpfnOld) End If End IfEnd Function
Public Function WndProc (Byval Hwnd As Long, Byval WParam As Long, Byval LParam As Long) As long Select Case UMSG
