vb html listview,VB可以编辑的Listview

文件一，Form1.frm

加入一个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, 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, 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

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 ''

''

========================================================================

'' 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 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

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)

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

Private Const OLDWNDPROC = "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 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

'' ======================================================

'' 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