★可以编辑的ListView (Frame + TextBox)VBA版1★

office2008 · 发表于 2010-4-25 21:48

'模块1 代码: 以下代码出自于老外之手,首先非常感谢他,我在这里只是把代码引进了 EXCEL VBA,当然其他VBA大多也可
'此版本为 ListView + Frame + TextBox 组合, 大家知道在EXCEL VBA中 ,TextBox控件没有句柄也无法置于 LISTVIEW 上层, 但 EH LDY 指点 FRAME(框架)控件是可以置于 LISTVIEW 之上, 而且可通过 FRAME1.SETFOCUS 得到焦点 ,然后利用 API 函数 GetFocus 得到句柄,然后就可以指挥它做我们要它做的大多数事.

Option Explicit
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 Long) As Integer
Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Declare 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 wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Const WM_DESTROY = &H2
Private Const WM_KILLFOCUS = &H8
Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_WNDPROC = (-4)
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetFocus Lib "user32" () As Long
Private Const OLDWNDPROC = "OldWndProc"
Public Const LVI_NOITEM = -1
Public Const LVM_FIRST = &H1000
Public Const LVM_GETSUBITEMRECT = (LVM_FIRST + 56)
Public Const LVM_SUBITEMHITTEST = (LVM_FIRST + 57)
Public Const LVIR_ICON = 1
Public Const LVIR_LABEL = 2
Public Type LVHITTESTINFO
pt As POINTAPI
flags As Long
iItem As Long
iSubItem As Long
End Type
Public Const LVHT_ONITEMLABEL = &H4
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
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 If
End Function
Public Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case uMsg
Case WM_KILLFOCUS
Call CallWindowProc(GetProp(hWnd, OLDWNDPROC), hWnd, uMsg, wParam, lParam)
Call UserForm1.HideTextBox(True)
Exit Function
Case WM_DESTROY
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

复制代码

'以下是窗体代码:

Private Const SB_HORZ = &H0
Private Const SB_VERT = &H1
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 ListView1_DblClick()
Dim lvhti As LVHITTESTINFO
Dim rc As RECT
Dim hWnd As Long
Dim li As ListItem
If (GetKeyState(1) And &H8000) Then 'vbKeyLButton鼠标左键,双击
Call GetCursorPos(lvhti.pt)
Call ScreenToClient(m_hwndLV, lvhti.pt)
If (ListView_SubItemHitTest(m_hwndLV, lvhti) <> LVI_NOITEM) Then
If lvhti.iSubItem Then
If ListView_GetSubItemRect(m_hwndLV, lvhti.iItem, lvhti.iSubItem, LVIR_LABEL, rc) Then
hWnd = FindWindow(vbNullString, Me.Caption)
Call MapWindowPoints(m_hwndLV, hWnd, rc, 2)
Frame1.Move (rc.Left) * 15 / 20, _
rc.Top * 15 / 20, _
(rc.Right - rc.Left) * 15 / 20 + 1, _
(rc.Bottom - rc.Top) * 15 / 20 + 1
Text1.Move -2, -2, (rc.Right - rc.Left) * 15 / 20 + 1, _
(rc.Bottom - rc.Top) * 15 / 20 + 1
m_iItem = lvhti.iItem + 1
m_iSubItem = lvhti.iSubItem
If m_iSubItem > 1 Then
Text1.Text = ListView1.ListItems(m_iItem).SubItems(m_iSubItem)
Text1.Tag = Text1.Text
ListView1.ListItems(m_iItem).SubItems(m_iSubItem) = ""
Frame1.Visible = True '为得到焦点
Frame1.SetFocus '为得到焦点
m_hwndTB = GetFocus() '为得到焦点
ListView1.SetFocus '转移焦点
Frame1.ZOrder 0
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
Text1.SetFocus
'可以用其他程序代替它
Call SubClass(m_hwndTB, AddressOf WndProc)
End If
End If
End If
End If
End If
End Sub
Private Sub Text1_GotFocus()
' ListView1.ListItems(m_iItem).Selected = True
End Sub
Private Sub Text1_Change()
If m_iItem Then Text1.Width = ListView1.ColumnHeaders(m_iSubItem + 1).Width
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)
Frame1.Visible = False
Text1 = ""
m_iItem = 0
End Sub
Private Sub Text1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If (KeyAscii = vbKeyReturn) Then
Call HideTextBox(True)
KeyAscii = 0
ElseIf (KeyAscii = vbKeyEscape) Then
Call HideTextBox(False)
KeyAscii = 0
End If
End Sub
Private Sub UserForm_Initialize()
Me.Frame1.ZOrder 1
With ListView1
.LabelEdit = lvwManual
.HideSelection = False
.Appearance = cc3D
.Icons = ImageList1
.MultiSelect = True
.Gridlines = True
.View = lvwReport
.FullRowSelect = True
.SmallIcons = ImageList1
m_hwndLV = .hWnd
For i = 1 To 4
.ColumnHeaders.Add Text:="column" & i
Next
For i = &H0 To &HF
Set Item = .ListItems.Add(, , "item" & i, &H1, &H1)
Item.SubItems(1) = i * 10
Item.SubItems(2) = i * 100
Item.SubItems(3) = i * 1000
Next
End With
End Sub

复制代码

[ 本帖最后由 office2008 于 2010-4-27 14:58 编辑 ]

aidixiao · 发表于 2010-4-25 22:58

感谢大侠分享。

qczvba · 发表于 2010-7-7 14:51

高手中和高手，引用别的就是高手，一般人还不会引用。谢谢楼主分享。

sendsend · 发表于 2010-7-31 21:40

楼子的水平高，菜鸟还无法运用，下面的listview模糊查询如何实现可编辑啊？谢谢！

http://club.excelhome.net/viewth ... e%3D1&frombbs=1

lanceflyliu · 发表于 2010-8-13 09:38

谢谢楼主的分享，个人水平有限不太明白

thtfzhaobo · 发表于 2010-8-13 13:16

留个脚印，待学习

zhyd111 · 发表于 2010-9-4 10:59

不太明白，学习中。谢谢分享！

stephen1707 · 发表于 2010-10-19 09:03

多谢分享，收下慢慢研究！

hhzjxss · 发表于 2010-10-20 10:08

谢谢分享，学习你的两个版本

cnzjjhzjf · 发表于 2010-10-20 10:18

还没用过LISTVIEW，先占个位，用到再学一下！

		自动登录	找回密码
密码			免费注册

[分享] ★可以编辑的ListView (Frame + TextBox)VBA版1★

评分