VB编辑ListView的SubItem

 

加入一个Listview,两个Imagelist,一个文本框

Option   Explicit
'
'
 Copyright ?1997-1999 Brad Martinez, http://www.mvps.org
'
'
 Demonstrates how to in place do SubItem editing in the VB ListView.

Private  m_hwndLV  As   Long     '  ListView1.hWnd
Private  m_hwndTB  As   Long     '  TextBox1.hWnd
Private  m_iItem  As   Long           '  ListItem.Index whose SubItem is being edited
Private  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, 11)
      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, ScaleHeight
End 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_SubItemHitTest
  End If   ' GetKeyState(vbKeyLButton)
  
End Sub


'  Selects the ListItem whose SubItem is being edited...

Private   Sub Text1_GotFocus()
  ListView1.ListItems(m_iItem).Selected 
= True
End Sub


'  If the TextBox is shown, size its width so that it's always a little
'
 longer than the length of its Text.

Private   Sub Text1_Change()
  
If m_iItem Then Text1.Width = TextWidth(Text1) + 180
End 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



文件二:Module1.bas

Option   Explicit
'
'
 Copyright ?1997-1999 Brad Martinez, http://www.mvps.org
'
Public  Type POINTAPI    '  pt
  X  As   Long
  Y 
As   Long
End  Type

Public  Type RECT    '  rct
   Left   As   Long
  Top 
As   Long
  
Right   As   Long
  Bottom 
As   Long
End  Type

Declare   Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As KeyCodeConstants) As Integer

Declare Function SetParent Lib "user32" (ByVal hWndChild As LongByVal hWndNewParent As LongAs Long
Declare Function MapWindowPoints Lib "user32" (ByVal hwndFrom As LongByVal hwndTo As Long, lppt As Any, ByVal cPoints As LongAs Long

Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
                            (
ByVal hWnd As Long, _
                            
ByVal wMsg As Long, _
                            
ByVal wParam As Long, _
                            lParam 
As Any) As Long   ' <---

' ========================================================================
'
 listview defs

#
Const WIN32_IE = &H300

' user-defined
Public Const LVI_NOITEM = -1

' messages
Public Const LVM_FIRST = &H1000
#
If (WIN32_IE >= &H300) Then
Public Const LVM_GETSUBITEMRECT = (LVM_FIRST + 56)
Public Const LVM_SUBITEMHITTEST = (LVM_FIRST + 57)
#
End If

' LVM_GETSUBITEMRECT rct.Left
Public Const LVIR_ICON = 1
Public 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 If
End Type

' LVHITTESTINFO flags
Public 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


#
End If  ' ' WIN32_IE >= &H300


文件三:mSubClass.bas

Option Explicit
'
'
 Copyright ?1997-1999 Brad Martinez, http://www.mvps.org
'
Private Const WM_DESTROY = &H2
Private Const WM_KILLFOCUS = &H8

Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As LongByVal lpString As StringAs Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As LongByVal lpString As StringByVal hData As LongAs Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As LongByVal lpString As StringAs Long

Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongByVal nIndex As LongByVal dwNewLong As LongAs Long
Private Const GWL_WNDPROC = (-4)

Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongByVal hWnd As LongByVal uMsg As LongByVal wParam As LongByVal lParam As LongAs Long

Private Const OLDWNDPROC = "OldWndProc"
'

Public Function SubClass(hWnd As Long, lpfnNew As LongAs Boolean
  
Dim lpfnOld As Long
  
Dim fSuccess As Boolean
  
  
If (GetProp(hWnd, OLDWNDPROC) = 0Then
    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 LongAs 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 If

End Function


Public Function WndProc(ByVal hWnd As LongByVal uMsg As LongByVal wParam As LongByVal lParam As LongAs Long
  
  
Select Case uMsg

    
' ======================================================
    ' Hide the TextBox when it loses focus (its LostFocus event it not fired
    ' when losing focus to a window outside the app).
    
    
Case WM_KILLFOCUS
      
' OLDWNDPROC will be gone after UnSubClass is called, HideTextBox
      ' calls UnSubClass.
      Call CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
      
Call Form1.HideTextBox(True)
      
Exit Function
    
    
' ======================================================
    ' Unsubclass the window when it's destroyed in case someone forgot...
    
    
Case WM_DESTROY
      
' OLDWNDPROC will be gone after UnSubClass is called!
      Call CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
      
Call UnSubClass(hWnd)
      
Exit Function
      
  
End Select
  
  WndProc 
= CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
  
End Function


评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值