动态拖曳ListBox Item位置
来源:cww

如果说，我们只是单的做到动态拖曳ListBox 的Item到新的位置，即改变ListBox内Items
的顺序，那应不困难，只要在ListBox 的MuseDown时记录是哪一个Item被选取，在MousUp
时删除本选取的Item再於新的位置新增一个Item，那便可以了；不过，讨厌的是如何在
MouseMove时顺带将方才选取起来的待Move的Item外面做一方框，如此才清楚的知道是哪
一个Item待Move。
画方框的API是Rectangle，它需hDc当第一个叁数，所以我们使用GetDc()来取得ListBox
的hDc，但是这个hDc目前在画方框时内定会用白色填满方框内部，所以我们设定hDc使用
Null Brush(使用SelectObject)，这样才会使Rectangle API画出一个只有框不会填满内
部的方形。相同的，我们要设定方框是以实线来画(使用SelectObject)。
剩下的重点就在於方框的位置如何决定，所幸有个Message可完成，LB_GETITEMRECT便是
我们想要的，其wParam传入ListBox中的Item Idex(以0为第一个，1为第二个以此类推)
lParam是传回一个RECT的Structure。 
'以下在.Bas
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 Long

Public Const PS_DOT = 2
Public Const LB_GETITEMRECT = &H198
Public Const NULL_BRUSH = 5

'以下在Form 需一个ListBox, MultiSelect = 0
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 String

Private 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 Sub

Private Sub Form_Unload(Cancel As Integer)
Dim i As Long
i = DeleteObject(hPen)
i = ReleaseDC(List1.hwnd, hldc)
End Sub

Private 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 Sub

Private 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 Sub

Private 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