Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton And Not ListView1.SelectedItem Is Nothing Then
ListView1.DragIcon = ListView1.SelectedItem.CreateDragImage
ListView1.Drag vbBeginDrag
End If
End Sub
If Button = vbLeftButton And Not ListView1.SelectedItem Is Nothing Then
ListView1.DragIcon = ListView1.SelectedItem.CreateDragImage
ListView1.Drag vbBeginDrag
End If
End Sub
ok ？
=============================================================
Private m_hwndLV As Long ' ListView1.hWnd
Private m_fDragging As Boolean ' flag indicating whether we're currently dragging or not
Private m_nButton As Integer ' index of button used for dragging (vbLeftButton or vbRightButton)
Private m_ptOrigCursor As POINTAPI ' position of cursor at button down, in ListView client pixels
Private m_ptOrigOrigin As POINTAPI ' the ListView's view origin at button down, in ListView client pixelsPrivate m_ptPrevCursor As POINTAPI ' position of cursor at last item move, in ListView client pixels
Private m_ptPrevOrigin As POINTAPI ' the ListView's previous view origin at last item move, in ListView client pixels
Private m_szTPP As SIZE ' Screen.TwipsPerPixelX/Y, in twipsPrivate Sub Form_Load()
Dim i As Integer
' Initialize the ImageLists
With ImageList1
.ImageWidth = 32
.ImageHeight = 32
.ListImages.Add Picture:=Icon
End With
With ImageList2
.ImageWidth = 16
.ImageHeight = 16
.ListImages.Add Picture:=Icon
End With
' Initialize and fill up the ListView
With ListView1
.ColumnHeaders.Add Text:="column1"
.Icons = ImageList1
.SmallIcons = ImageList2
.MultiSelect = True
m_hwndLV = .hWnd
For i = 1 To 20
Call .ListItems.Add(, , "item" & Format$(i, "00 "), 1, 1)
Next
End With
Call SubClass(hWnd, AddressOf WndProc)
' Store the respective twips/pixel values
m_szTPP.cx = Screen.TwipsPerPixelX
m_szTPP.cy = Screen.TwipsPerPixelY
' And the ancillary UI...
Show
Call SwitchView(lvwIcon)
Call mnuViewArrangeAZ_Click
End SubPrivate Sub Form_Resize()
ListView1.Move 0, 0, ScaleWidth, ScaleHeight
End Sub
Private Sub ListView1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
' If not yet dragging, save the index of the currently depressed button.
If (m_fDragging = False) Then m_nButton = Button
End Sub
Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If m_fDragging And (m_nButton = Button) Then
Call DoDrag(x / m_szTPP.cx, y / m_szTPP.cy)
End If
End Sub
Private Sub ListView1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If m_fDragging Then
Call EndDrag
Call MoveListItems(x \ m_szTPP.cx, y \ m_szTPP.cy)
End If
End Sub
Private Sub ListView1_KeyPress(KeyAscii As Integer)
If m_fDragging And (KeyAscii = vbKeyEscape) Then
Call EndDrag
Call MoveListItems(0, 0, True)
KeyAscii = 0
End If
End Sub
Public Sub BeginDrag(x As Long, y As Long)
Dim pt As POINTAPI
m_fDragging = True
m_ptPrevCursor.x = x
m_ptPrevCursor.y = y
Call ListView_GetOrigin(m_hwndLV, m_ptPrevOrigin) m_ptOrigCursor = m_ptPrevCursor
m_ptOrigOrigin = m_ptPrevOrigin
Call GetCursorPos(pt)
Call ScreenToClient(m_hwndLV, pt)
Call MoveListItems(pt.x, pt.y)
Call SetCapture(m_hwndLV)End Sub
Private Sub DoDrag(x As Long, y As Long)
Dim rcClient As RECT
Call GetClientRect(m_hwndLV, rcClient)
If PtInRect(rcClient, x, y) Then
Call MoveListItems(x, y)
Screen.MousePointer = vbDefault
Else
Screen.MousePointer = vbNoDrop
End If
End SubPrivate Sub EndDrag()
Call ReleaseCapture
Screen.MousePointer = vbDefault
m_fDragging = False
m_nButton = 0End Sub
Private Sub MoveListItems(x As Long, y As Long, Optional fCancelDrag As Boolean = False)
Dim rcClient As RECT
Dim ptOrigin As POINTAPI
Dim dx As Long
Dim dy As Long
' If in either large or small icon view (no repositioning in list or details view)
If (ListView1.View = lvwIcon) Or (ListView1.View = lvwSmallIcon) Then
' Proceed only if the specified point is within the ListView's client area.
Call GetClientRect(m_hwndLV, rcClient)
If PtInRect(rcClient, x, y) Then
' If the dragging has not been cancelled...
If (fCancelDrag = False) Then
Call ListView_GetOrigin(m_hwndLV, ptOrigin)
dx = (x - m_ptPrevCursor.x) + (ptOrigin.x - m_ptPrevOrigin.x)
dy = (y - m_ptPrevCursor.y) + (ptOrigin.y - m_ptPrevOrigin.y)
' Debug.Print m_ptPrevOrigin.x; m_ptPrevOrigin.y, ptOrigin.x; ptOrigin.y, dx; dy
' Save the previous cursor position and origin to be used again above.
m_ptPrevCursor.x = x
m_ptPrevCursor.y = y
m_ptPrevOrigin = ptOrigin
Else
' Dragging is cancelled, restore all ListItems to their pre-drag positions
dx = (m_ptOrigCursor.x - m_ptPrevCursor.x) + (m_ptOrigOrigin.x - m_ptPrevOrigin.x)
dy = (m_ptOrigCursor.y - m_ptPrevCursor.y) + (m_ptOrigOrigin.y - m_ptPrevOrigin.y)
End If
Call SendMessage(m_hwndLV, WM_SETREDRAW, 0, 0)
Call MoveSelectedListItemsVB(dx * m_szTPP.cx, dy * m_szTPP.cy)
' Call MoveSelectedListItemsAPI(dx, dy)
Call SendMessage(m_hwndLV, WM_SETREDRAW, 1, 0)
If fCancelDrag And ((ListView1.SelectedItem Is Nothing) = False) Then
ListView1.SelectedItem.EnsureVisible
End If
Call UpdateWindow(m_hwndLV)
End If ' PtInRect
End If ' ListView1.View
End Sub
Private Sub MoveSelectedListItemsVB(dx As Single, dy As Single)
Dim item As ListItem
Dim x As Single
Dim y As Single For Each item In ListView1.ListItems
If item.Selected Then
x = item.Left + dx
If (x < 0) Then x = x - m_szTPP.cx
item.Left = x
y = item.Top + dy
If (y < 0) Then y = y - m_szTPP.cy
item.Top = y
End If
NextEnd SubPrivate Sub MoveSelectedListItemsAPI(dx As Long, dy As Long)
Dim i As Long
Dim pt As POINTAPI i = -1
Do
i = ListView_GetNextItem(m_hwndLV, i, LVNI_SELECTED)
If (i <> -1) Then
Call ListView_GetItemPosition(m_hwndLV, i, pt)
' Call ListView_SetItemPosition(m_hwndLV, i, pt.x + dx, pt.y + dy)
Call ListView_SetItemPosition32(m_hwndLV, i, pt.x + dx, pt.y + dy)
End If
Loop While (i <> -1)End Sub
Private Sub mnuView_Click()
mnuViewArrangeAuto.Enabled = ((ListView1.View = lvwIcon) Or (ListView1.View = lvwSmallIcon))
End SubPrivate Sub mnuViewLargeIcons_Click()
Call SwitchView(lvwIcon)
End SubPrivate Sub mnuViewSmallIcons_Click()
Call SwitchView(lvwSmallIcon)
End SubPrivate Sub mnuViewList_Click()
Call SwitchView(lvwList)
End SubPrivate Sub mnuViewReport_Click()
Call SwitchView(lvwReport)
End SubPrivate Sub SwitchView(dwNewView As ListViewConstants)
ListView1.View = dwNewView
' A bug: http://support.microsoft.com/support/kb/articles/q143/4/06.asp
ListView1.Arrange = lvwAutoTop
If (mnuViewArrangeAuto.Checked = False) Then
ListView1.Arrange = lvwNone
End If
Call ListView_GetOrigin(m_hwndLV, m_ptPrevOrigin)
mnuViewLargeIcons.Checked = (dwNewView = lvwIcon)
mnuViewSmallIcons.Checked = (dwNewView = lvwSmallIcon)
mnuViewList.Checked = (dwNewView = lvwList)
mnuViewReport.Checked = (dwNewView = lvwReport)End SubPrivate Sub mnuViewSelAll_Click()
Call ListView_SelectAll(m_hwndLV)
End SubPrivate Sub mnuViewArrangeAZ_Click()
mnuViewArrangeAZ.Checked = True
mnuViewArrangeZA.Checked = False
ListView1.SortOrder = lvwAscending
ListView1.Sorted = True
End SubPrivate Sub mnuViewArrangeZA_Click()
mnuViewArrangeAZ.Checked = False
mnuViewArrangeZA.Checked = True
ListView1.SortOrder = lvwDescending
ListView1.Sorted = True
End SubPrivate Sub mnuViewArrangeAuto_Click()
If (mnuViewArrangeAuto.Checked = False) Then
mnuViewArrangeAuto.Checked = True
ListView1.Arrange = lvwAutoTop
Else
mnuViewArrangeAuto.Checked = False
ListView1.Arrange = lvwNone
End If
End Sub
Private Sub ListView1_KeyDown(KeyCode As Integer, Shift As Integer)
If (Shift And vbCtrlMask) And (KeyCode = vbKeyA) Then
Call ListView_SelectAll(m_hwndLV)
End If
End Sub
========================================================
Public Type SIZE
cx As Long
cy As Long
End TypePublic Type POINTAPI ' pt
x As Long
y As Long
End TypePublic Type RECT ' rct
Left As Long
Top As Long
Right As Long
Bottom As Long
End TypeDeclare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As LongDeclare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As Any) As Long ' lpPoint As POINTAPI) As Long
Declare Function PtInRect Lib "user32" (lprc As RECT, ByVal x As Long, ByVal y As Long) As Long
Declare Function UpdateWindow Lib "user32" (ByVal hWnd As Long) As LongPublic Const WM_SETREDRAW = &HBDeclare 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' messages
Public Const LVM_FIRST = &H1000
Public Const LVM_GETNEXTITEM = (LVM_FIRST + 12)
'Public Const LVM_SETITEMPOSITION = (LVM_FIRST + 15)
Public Const LVM_GETITEMPOSITION = (LVM_FIRST + 16)
Public Const LVM_GETORIGIN = (LVM_FIRST + 41)
Public Const LVM_SETITEMSTATE = (LVM_FIRST + 43)
Public Const LVM_SETITEMPOSITION32 = (LVM_FIRST + 49)' LVM_GETNEXTITEM LOWORD lParam
Public Const LVNI_FOCUSED = &H1
Public Const LVNI_SELECTED = &H2' LVITEM state and statemask flag
Public Const LVIS_SELECTED = &H2Public Type LVITEM ' was LV_ITEM
mask As Long
iItem As Long
iSubItem As Long
state As Long
stateMask As Long
pszText As Long ' if String, must be pre-allocated
cchTextMax As Long
iImage As Long
lParam As Long
#If (WIN32_IE >= &H300) Then
iIndent As Long
#End If
End Type' notifications
Public Const LVN_FIRST = -100& ' (0U-100U)
Public Const LVN_BEGINDRAG = (LVN_FIRST - 9) ' lParam = NMLISTVIEW
Public Const LVN_BEGINRDRAG = (LVN_FIRST - 11) ' lParam = NMLISTVIEWPublic Type NMLISTVIEW ' was NM_LISTVIEW
hdr As NMHDR
iItem As Long
iSubItem As Long
uNewState As Long
uOldState As Long
uChanged As Long
ptAction As POINTAPI
lParam As Long
End Type
'
Public Function ListView_GetNextItem(hWnd As Long, i As Long, flags As Long) As Long
ListView_GetNextItem = SendMessage(hWnd, LVM_GETNEXTITEM, ByVal i, ByVal flags) ' MAKELPARAM(flags, 0))
End Function' Returns the index of the item that is selected and has the focus rectangle (user-defined)Public Function ListView_GetSelectedItem(hwndLV As Long) As Long
ListView_GetSelectedItem = ListView_GetNextItem(hwndLV, -1, LVNI_FOCUSED Or LVNI_SELECTED)
End Function
'
'Public Function ListView_SetItemPosition(hwndLV As Long, i As Long, x As Long, y As Long) As Boolean
' ListView_SetItemPosition = SendMessage(hwndLV, LVM_SETITEMPOSITION, ByVal i, ByVal MAKELPARAM(x, y))
'End FunctionPublic Function ListView_GetItemPosition(hwndLV As Long, i As Long, ppt As POINTAPI) As Boolean
ListView_GetItemPosition = SendMessage(hwndLV, LVM_GETITEMPOSITION, ByVal i, ppt)
End Function
Public Function ListView_GetOrigin(hwndLV As Long, ppt As POINTAPI) As Boolean
ListView_GetOrigin = SendMessage(hwndLV, LVM_GETORIGIN, 0, ppt)
End Function
Public Sub ListView_SetItemPosition32(hwndLV As Long, i As Long, x As Long, y As Long)
Dim ptNewPos As POINTAPI
ptNewPos.x = x
ptNewPos.y = y
Call SendMessage(hwndLV, LVM_SETITEMPOSITION32, ByVal i, ptNewPos)
End SubPublic Function ListView_SetItemState(hwndLV As Long, i As Long, state As Long, mask As Long) As Boolean
Dim lvi As LVITEM
lvi.state = state
lvi.stateMask = mask
ListView_SetItemState = SendMessage(hwndLV, LVM_SETITEMSTATE, ByVal i, lvi)
End Function' Selects all listview items. The item with the focus rectangle maintains it (user-defined).Public Function ListView_SelectAll(hwndLV As Long) As Boolean
ListView_SelectAll = ListView_SetItemState(hwndLV, -1, LVIS_SELECTED, LVIS_SELECTED)
End Function
======================================================== Public Type NMHDR
hwndFrom As Long ' Window handle of control sending message
idFrom As Long ' Identifier of control sending message
code As Long ' Specifies the notification code
End TypePrivate Const WM_NOTIFY = &H4E
Private Const WM_DESTROY = &H2Private 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 LongDeclare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)Public Enum GWL_nIndex
GWL_WNDPROC = (-4)
' GWL_HWNDPARENT = (-8)
GWL_ID = (-12)
GWL_STYLE = (-16)
GWL_EXSTYLE = (-20)
' GWL_USERDATA = (-21)
End EnumDeclare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As GWL_nIndex) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As GWL_nIndex, ByVal dwNewLong As Long) As LongPrivate 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 Declare Function DefWindowProc Lib "user32" Alias "DefWindowProcA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As LongPrivate Const OLDWNDPROC = "OldWndProc"
Private Const OBJECTPTR = "ObjectPtr"#If DEBUGWINDOWPROC Then
' maintains a WindowProcHook reference for each subclassed window.
' the window's handle is the collection item's key string.
Private m_colWPHooks As New Collection
#End If
'Public Function SubClass(hWnd As Long, _
lpfnNew As Long, _
Optional objNotify As Object = Nothing) As Boolean
Dim lpfnOld As Long
Dim fSuccess As Boolean
On Error GoTo Out
If GetProp(hWnd, OLDWNDPROC) Then
SubClass = True
Exit Function
End If
#If (DEBUGWINDOWPROC = 0) Then
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, lpfnNew)#Else
Dim objWPHook As WindowProcHook
Set objWPHook = CreateWindowProcHook
m_colWPHooks.Add objWPHook, CStr(hWnd)
With objWPHook
Call .SetMainProc(lpfnNew)
lpfnOld = SetWindowLong(hWnd, GWL_WNDPROC, .ProcAddress)
Call .SetDebugProc(lpfnOld)
End With#End If
If lpfnOld Then
fSuccess = SetProp(hWnd, OLDWNDPROC, lpfnOld)
If (objNotify Is Nothing) = False Then
fSuccess = fSuccess And SetProp(hWnd, OBJECTPTR, ObjPtr(objNotify))
End If
End If
Out:
If fSuccess Then
SubClass = True
Else
If lpfnOld Then Call SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld)
MsgBox "Error subclassing window &H" & Hex(hWnd) & vbCrLf & vbCrLf & _
"Err# " & Err.Number & ": " & Err.Description, vbExclamation
End If
End FunctionPublic Function UnSubClass(hWnd As Long) As Boolean
Dim lpfnOld As Long
lpfnOld = GetProp(hWnd, OLDWNDPROC)
If lpfnOld Then
If SetWindowLong(hWnd, GWL_WNDPROC, lpfnOld) Then
Call RemoveProp(hWnd, OLDWNDPROC)
Call RemoveProp(hWnd, OBJECTPTR)#If DEBUGWINDOWPROC Then
' remove the WindowProcHook reference from the collection
m_colWPHooks.Remove CStr(hWnd)
#End If
UnSubClass = True
End If ' SetWindowLong
End If ' lpfnOldEnd Function' Returns the specified object reference stored in the subclassed
' window's OBJECTPTR window property.
' The object reference is valid for only as long as the calling proc holds it.Public Function GetObj(hWnd As Long) As Object
Dim Obj As Object
Dim pObj As Long
pObj = GetProp(hWnd, OBJECTPTR)
If pObj Then
MoveMemory Obj, pObj, 4
Set GetObj = Obj
MoveMemory Obj, 0&, 4
End If
End FunctionPublic Function WndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Debug.Print uMsg
Select Case uMsg
' ======================================================
' Initiate dragging by calling the Form's public BeginDrag procedure. We
' only have to eat the LVN_BEGINDRAG notification (don't pass it to
' CallWindowProc) to prevent the ListView from doing its default left button
' item dragging. The ListView does not process LVN_BEGINRDRAG
Case WM_NOTIFY
Dim nmh As NMHDR
Dim nnlv As NMLISTVIEW MoveMemory nmh, ByVal lParam, Len(nmh)
'Debug.Print nmh.code
Select Case nmh.code
Case LVN_BEGINDRAG, LVN_BEGINRDRAG
MoveMemory nnlv, ByVal lParam, Len(nnlv)
Call Form1.BeginDrag(nnlv.ptAction.x, nnlv.ptAction.y)
Exit Function
End Select
' ======================================================
' Unsubclass the window.
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
你的代码我测试了没有产生DragImage呀！
=======================================================
Dim li2 As ListItem
Dim moDragNode As NodePrivate Sub Form_Load()' NOTE: ******************
' Please make sure that the following properties are set accordingly
' With ListView1
' .OLEDragMode = ccOLEDragManual
' .OLEDropMode = ccOLEDropNone
' End With
' With TreeView1
' .LineStyle = tvwRootLines
' .OLEDragMode = ccOLEDragAutomatic
' .OLEDropMode = ccOLEDropManual
' End With Dim str As String
Dim cnt, k As Integer
Dim Li As ListItem ' Declare List item variable.
Dim nodX As Node ' Declare Node variable.
' Populating the Listview control
Set Li = ListView1.ListItems.Add(, , "Item1")
Set Li = ListView1.ListItems.Add(, , "Item2")
Set Li = ListView1.ListItems.Add(, , "Item3")
ListView1.View = lvwList
'Populating the tree control
' First node with 'Root' as text.
For cnt = 1 To 2
Set nodX = TreeView1.Nodes.Add(, , "r" & cnt, "Root" & cnt)
Next
' This next node is a child of Node 1 ("r").
For k = 1 To 2
str = "r" & k
For cnt = 1 To 5
Set nodX = TreeView1.Nodes.Add(str, tvwChild, "child" & k & cnt, "Child" & k & cnt)
Next
Next
TreeView1.Nodes(1).Selected = True
TreeView1.Nodes(1).Expanded = True
End SubPrivate Sub ListView1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Set ListView1.SelectedItem = ListView1.HitTest(x, y)
' In the following line any ICO file will do
ListView1.DragIcon = LoadPicture(AppPath & "HelloSir.ICO")
ListView1.Drag vbBeginDrag
End Sub
Private Sub TreeView1_DragDrop(Source As Control, x As Single, y As Single) Set li2 = ListView1.SelectedItem
If li2 Is Nothing Then Exit Sub
Dim TN As Node
' Check if any itme in the treeview is highlighted or selected
If TreeView1.DropHighlight Is Nothing Then
Set TreeView1.DropHighlight = TreeView1.HitTest(x, y)
TreeView1.SelectedItem = TreeView1.DropHighlight
If TreeView1.SelectedItem Is Nothing Then
' If no item is selected, then place the list item
' as root node.
Set TN = TreeView1.Nodes.Add(, , li2.Key, li2.Text)
Else
' If any itme is selected, then place the list item
' as its Child node
Set moDragNode = TreeView1.SelectedItem
Set TN = TreeView1.Nodes.Add(moDragNode, tvwChild, li2.Key, li2.Text)
End If
End If
Set TreeView1.DropHighlight = Nothing
End SubPrivate Function AppPath() As String
Dim sAns As String
sAns = App.Path
If Right(App.Path, 1) <> "\" Then sAns = sAns & "\"
AppPath = sAnsEnd Function
由于 我无法 测试(在网吧,没vb), 所以我只有把代码 贴出来 让你自己 调试了.