マウスのドラッグ・アンド・ドロップで項目の移動
                                                         玄関へお回り下さい。
同一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