如何拖放listbox中选定的条目？

Question

就像winamp中的列表那样拖动条目

Answer 1

Dim thesong As String
Dim takesong As StringPrivate Sub Command1_Click()
List2.Clear
End SubPrivate Sub Command2_Click()
Unload Me
End
End SubPrivate Sub Form_Load()
List1.AddItem "Song1"
List1.AddItem "Song2"
List1.AddItem "Song3"
List1.AddItem "Song4"
List1.AddItem "Song5"
End SubPrivate Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Exit Sub
MousePointer = 0
takesong$ = ""
End SubPrivate Sub Frame1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Exit Sub
takesong$ = ""
 MousePointer = 0End SubPrivate Sub Frame2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then Exit Sub
takesong$ = ""
MousePointer = 0End SubPrivate Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If List1 = "" Then Exit Sub
If Button = 1 Then
thesong$ = List1.ListIndex
takesong$ = List1.List(thesong$)
MousePointer = 2
End If
End SubPrivate Sub List2_DblClick()
If List2 = "" Then Exit Sub
Dim a As String
a$ = List2.ListIndex
List2.RemoveItem a$
End SubPrivate Sub List2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If takesong$ = "" Then Exit Sub
List2.AddItem takesong$
takesong$ = ""
If Button = 0 Then MousePointer = 0
End Sub

Answer 2

我的问题提的不够清楚吗？
在同一个LISTBOX中移动条目啊。

Answer 3

sorry!没看清! :P新建的VB工程添加一个模块,增加如下代码
Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function GetStockObject Lib "gdi32" (ByVal nIndex 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 LongPublic Const PS_DOT = 2
Public Const LB_GETITEMRECT = &H198
Public Const NULL_BRUSH = 5
在Form中增加如下代码
Option Explicit
Dim rect5 As RECT
Dim hldc As Long, hPen As Long, hBrush As Long
Dim FirstIndex As Long, ntx As Long, ntxStr As StringPrivate Sub Form_Load()
hPen = CreatePen(0, 1, RGB(0, 0, 0)) '设定黑色线
hBrush = GetStockObject(NULL_BRUSH)  '设定中空显示
hldc = GetDC(List1.hwnd)
Call SelectObject(hldc, hPen)
Call SelectObject(hldc, hBrush)
List1.Clear
List1.AddItem "111111111"
List1.AddItem "222222222"
List1.AddItem "333333333"
List1.AddItem "444444444"
List1.AddItem "555555555"
List1.AddItem "666666666"
List1.AddItem "777777777"
List1.AddItem "888888888"
List1.AddItem "999999999"
List1.AddItem "AAAAAAAAA"
List1.AddItem "BBBBBBBBB"
List1.AddItem "CCCCCCCCC"
End SubPrivate Sub Form_Unload(Cancel As Integer)
Dim i As Long
i = DeleteObject(hPen)
i = ReleaseDC(List1.hwnd, hldc)
End SubPrivate Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'取得List1.ListIndex所在Item的位置
Call SendMessage(List1.hwnd, LB_GETITEMRECT, List1.ListIndex, rect5)
FirstIndex = List1.TopIndex '目前ListBox最上面那个Item的注标
ntx = List1.ListIndex
ntxStr = List1.List(ntx)
List1.MousePointer = 15
End SubPrivate Sub List1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
   If FirstIndex = List1.TopIndex Then '当ListBox没有Scroll时则重画榘形
      Call Rectangle(hldc, rect5.Left, rect5.Top, rect5.Right, rect5.Bottom)
   Else  '否则重新取得待Move的Item之新位置
      Call SendMessage(List1.hwnd, LB_GETITEMRECT, ntx, rect5)
      FirstIndex = List1.TopIndex
   End If
End If
End SubPrivate Sub List1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
List1.Refresh '清除方才画上的榘形
If List1.ListIndex <> ntx And List1.ListIndex <> -1 Then
  '新增项目於新的位置，并将原本位置的项目删除
  List1.AddItem ntxStr, List1.ListIndex
  If List1.ListIndex > ntx Then
     List1.RemoveItem ntx
  Else '因项目往上移动，已新增了一个项目了，故原本记录的ntx位置也要加一
     List1.RemoveItem ntx + 1
  End If
  List1.ListIndex = List1.ListIndex - 1 '指到已Move完毕的Item
End If
List1.MousePointer = 0
End Sub