マウスのドラッグ・アンド・ドロップで項目の移動
 　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　玄関へお回り下さい。
同一ListBox内でマウスのドラッグ・アンド・ドロップによる項目の移動　　　　　　(148)
FormにListBoxを貼り付けておいて下さい。又、ドラッグ・ドロップ用のマウスアイコンをご用意下さい
　 Option Explicit　　 'SampleNo=148　WindowsXP VB6.0(SP5) 2002.06.16
'リストボックス中の指定されたポイントでアイテムの指標を検索する
Private Declare Function LBItemFromPt Lib "comctl32" _
　　(ByVal hLB As Long, ByVal x As Long, ByVal y As Long, _
　　 ByVal bAutoScroll As Long) As Long
'位置座標を受け取る構造体
Private Type POINTAPI
　　x As Long
　　y As Long
End Type
'現在のマウスカーソルの位置座標を取得する（P387)
Private Declare Function GetCursorPos Lib "user32" _
　　(lpPoint As POINTAPI) As Long
'カレントスレッドの実行を指定の時間だけ中断する(667)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private MouseDrg As Integer　　 'マウスのドラッグ状況
Private DrgStr　 As String　　　'移動元のデータ
Private XPos　　 As Long　　　　'ドラッグ開始位置座標
Private YPos　　 As Long　　　　'ドラッグ開始位置座標
Private oldIndex As Long　　　　'元の行の位置
Private NewIndex As Long　　　　'現在の行の位置
Private TmpIndex As Long　　　　'事前の行の位置


Private Sub Form_Load()
　　List1.AddItem "１　　マウスのドラッグ・アンド・ドロップで"
　　List1.AddItem "２　　選択行の移動ができます。"
　　List1.AddItem "３　　現在の行の下側に挿入されます。"
　　List1.AddItem "４　　先頭行に移動したい場合は上側の"
　　List1.AddItem "５　　枠外にドロップして下さい。"
End Sub


Private Sub List1_MouseDown(Button As Integer, _
　　　　　　　　　　　　　　 Shift As Integer, x As Single, y As Single)
'マウスの左ボタンが押された場合
　　If MouseDrg = 0 And Button = 1 Then
　　　　XPos = x　　　　'マウス座標
　　　　YPos = y　　　　'マウス座標
　　　　MouseDrg = 1　　'ドラッグの開始
　　End If
End Sub


Private Sub List1_MouseMove(Button As Integer, _
　　　　　　　　　　　　　　 Shift As Integer, x As Single, y As Single)
'マウスのドラッグ中の処理
　　If MouseDrg = 2 Then
　　　　Dim MPos As POINTAPI
　　　　GetCursorPos MPos　　　 '現在のマウス座標を取得
　　　　'そのマウス座標から行位置を取得
　　　　NewIndex = LBItemFromPt(List1.hWnd, MPos.x, MPos.y, False)
　　　　If NewIndex <> -1 Then　　　　　　　　　'選択行位置が取得できたら
　　　　　　List1.Selected(NewIndex) = True　　 '正常位置の場合
　　　　　　TmpIndex = NewIndex
　　　　Else
　　　　　　List1.Selected(TmpIndex) = False　　'異常位置の場合
　　　　End If
　　End If
　　'左ボタンを押したままマウスが移動した場合
　　If MouseDrg = 1 And (YPos <> y Or XPos <> x) Then
　　　　With List1　　　'移動するデータと移動行を取得
　　　　　　'マウスアイコンを変更（各自用意して下さい)
　　　　　　Set .MouseIcon = LoadPicture("DRAG1PG.ICO")
　　　　　　DrgStr = .List(.ListIndex)
　　　　　　oldIndex = .ListIndex
　　　　　　If oldIndex < 0 Or oldIndex > .ListCount - 1 Then
　　　　　　　 MouseDrg = 0
　　　　　　　 Exit Sub
　　　　　　End If
　　　　End With
　　　　MouseDrg = 2　　'ドラッグ中のフラグ
　 End If
End Sub


Private Sub List1_MouseUp(Button As Integer, _
　　　　　　　　　　　　　 Shift As Integer, x As Single, y As Single)
'ドロップされた場合の処理
　　If MouseDrg = 2 Then
　　　　If NewIndex = -1 And TmpIndex = 0 Then
　　　　　　NewIndex = 0　　　　　　　　'上の枠外にドロップされた場合
　　　　ElseIf NewIndex = -1 And TmpIndex > 0 Then
　　　　　　NewIndex = TmpIndex + 1　　 '下の枠外にドロップされた場合
　　　　Else
　　　　　　NewIndex = NewIndex + 1　　 '通常位置にドロップの場合
　　　　End If
　　　　'マウスアイコンを変更（各自用意して下さい)
　　　　Set List1.MouseIcon = LoadPicture("Drop1pg.ico")　　'アイコンを変更
　　　　List1.AddItem DrgStr, NewIndex　　　　　　　　　'移動先に書込み
　　　　If NewIndex - 1 < oldIndex Then
　　　　　　oldIndex = oldIndex + 1　　 '先頭側に移動した場合の位置の補正
　　　　End If
　　　　List1.RemoveItem (oldIndex)　　 '移動元のデータを削除
　　　　Sleep 300　　　　　　　　　　　 'ドロップアイコンを少しの間表示
　　　　MouseDrg = 0
　　　　Set List1.MouseIcon = LoadPicture()
　　Else
　　　　MouseDrg = 0
　　　　Set List1.MouseIcon = LoadPicture()
　　　　DoEvents
　　End If
End Sub
　
通常は同一リストボックス内でのドラッグ・アンド・ドロップは出来ません。
出来ないとなると何とかしてみたいと思うのは、プログラマ（実はアマグラマ）の習性でしょうか？そこで、チョコット工夫をして実現して見ました。工夫したと言っても、マウス位置のアイテムNoを取得して、それを移動先に追加書き込みし、元のアイテムを削除しているだけですが。
例によって十分なエラーチェックをしておりませんので、ご使用環境・状況によっては満足な動作をしない場合があるかも知れません。　　　







2003/05/09