マウスのドラッグ・アンド・ドロップで項目の移動 |
同一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 "1 マウスのドラッグ・アンド・ドロップで" List1.AddItem "2 選択行の移動ができます。" List1.AddItem "3 現在の行の下側に挿入されます。" List1.AddItem "4 先頭行に移動したい場合は上側の" List1.AddItem "5 枠外にドロップして下さい。" 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