Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


8084 / 76732 ←次へ | 前へ→

【74226】Re:Listbox間のドラッグアンドドロップ
発言  Abyss  - 13/4/30(火) 18:23 -

引用なし
パスワード
   亜矢さん

その他にもいろいろ要望があると思いますよ。
ドラッグ状態でスクロールしたいとか、kanabunさんの
ご指摘のように、当ListBox中での並び替えなど。

> 選択行が色づけ(選択されている状態)がされていると、
> 今どの行へ移動中なのかがわかるので、....

APIの場合でしたらDrawInsert関数で矢印を付ける事が
可能ですが、UserformのListBoxには効果がないようです。

前回の提案コードから、いくつかの無駄を修正するついでに
今回の条件を取り入れてみました。
お試しください。

# UO3さん、ご感想ありがとうございます。
# 勝手ながらUO3さんのアイディアを使わせて頂いてます。

'**********
' (Userformモジュール)

Private col As Collection

Private Sub UserForm_Initialize()
  Dim e, cls As Class1
  Dim i As Long, j As Long, z As Long
  Dim SS$, arr(9, 3) As String
  
  Set col = New Collection
  
  ' サンプルデータ初期化
  For Each e In Array(ListBox1, ListBox2, ListBox3)
    SS = Array("\A", "\B", "\C", "\D")(z)
    e.ColumnCount = 4
    e.ColumnWidths = "25;25;25;25"
    For i = 0 To 9
      For j = 1 To 4
        arr(i, j - 1) = Format$(i * 10 + j, SS & "00")
      Next
    Next
    e.List = arr
    z = z + 1
    
    Set cls = New Class1
    Set cls.Member = e
    col.Add cls
  Next

End Sub

'***********
' (Class1モジュール)

Private Declare PtrSafe Function GetMessagePos& Lib "User32" ()
Private Declare PtrSafe Sub RtlMoveMemory Lib "Kernel32" _
  (pDesc As Any, _
   pSrc As Any, _
   Optional ByVal cbLen As Long = 4)

Private WithEvents LBox As MSForms.ListBox
Private mIndex As Long

Friend Property Set Member(ByVal rhs As MSForms.ListBox)
  Set LBox = rhs
End Property

Friend Property Get Member() As MSForms.ListBox
  Set Member = LBox
End Property

Friend Property Get Index() As Long
  Index = mIndex
End Property

Private Sub LBox_MouseMove(ByVal Button%, _
            ByVal Shift%, _
            ByVal X!, ByVal Y!)
  If Button <> vbKeyLButton Then Exit Sub
  
  mIndex = GetIndex(LBox)
  With New DataObject
    .SetText ObjPtr(Me)
    .StartDrag
  End With
  
End Sub

Private Sub LBox_BeforeDragOver(ByVal Cancel As ReturnBoolean, _
            ByVal Data As DataObject, _
            ByVal X!, ByVal Y!, _
            ByVal DragState As fmDragState, _
            ByVal Effect As ReturnEffect, _
            ByVal Shift%)
  Dim ptr As Long, buf As Long
  
  Cancel = True
  ptr = CLng(Data.GetText)
  
  If ptr = ObjPtr(Me) Then
    Effect = fmDropEffectNone: Exit Sub
  End If

  If Ptr2Cls(ptr).Index < 0 Then
    Effect = fmDropEffectNone: Exit Sub
  End If
  
  Effect = fmDropEffectMove
  
  buf = GetIndex(LBox)
  If mIndex = buf Then Exit Sub
  mIndex = buf
  LBox.ListIndex = buf
End Sub

Private Sub LBox_BeforeDropOrPaste(ByVal Cancel As ReturnBoolean, _
            ByVal Action As fmAction, _
            ByVal Data As DataObject, _
            ByVal X!, ByVal Y!, _
            ByVal Effect As ReturnEffect, _
            ByVal Shift%)

  Dim i As Long, NewIndex As Long
  Dim fIndex As Long
  Dim LBFrom As MSForms.ListBox
  
  If Action <> fmActionDragDrop Then Exit Sub
  
  With Ptr2Cls(CLng(Data.GetText))
    fIndex = .Index
    Set LBFrom = .Member
  End With
  
  NewIndex = GetIndex(LBox)
  
  With LBox
    .AddItem LBFrom.List(fIndex), NewIndex
    If NewIndex = -1 Then NewIndex = .ListCount + NewIndex
    For i = 1 To .ColumnCount - 1
      If i > LBFrom.ColumnCount Then Exit For
      .List(NewIndex, i) = LBFrom.List(fIndex, i)
    Next
    .SetFocus
    .ListIndex = NewIndex
  End With
  With LBFrom
    .RemoveItem fIndex
    .ListIndex = -1
  End With

End Sub

Private Function Ptr2Cls(ByVal ptr As Long) As Class1
  Dim tmp As Class1
  RtlMoveMemory tmp, ptr
  Set Ptr2Cls = tmp
  RtlMoveMemory tmp, 0&
End Function

Private Function GetIndex(ByVal acc As IAccessible) As Long
  Dim ii%(1)
  RtlMoveMemory ii(0), GetMessagePos()
  GetIndex = acc.accHitTest(ii(0), ii(1)) - 1
End Function
1 hits

【74193】Listbox間のドラッグアンドドロップ 亜矢 13/4/27(土) 20:52 質問
【74195】Re:Listbox間のドラッグアンドドロップ kanabun 13/4/27(土) 21:29 発言
【74197】Re:Listbox間のドラッグアンドドロップ 亜矢 13/4/28(日) 4:30 質問
【74198】Re:Listbox間のドラッグアンドドロップ UO3 13/4/28(日) 8:25 発言
【74199】Re:Listbox間のドラッグアンドドロップ kanabun 13/4/28(日) 8:31 発言
【74202】Re:Listbox間のドラッグアンドドロップ 亜矢 13/4/28(日) 12:25 発言
【74203】Re:Listbox間のドラッグアンドドロップ kanabun 13/4/28(日) 12:26 発言
【74204】Re:Listbox間のドラッグアンドドロップ kanabun 13/4/28(日) 14:40 発言
【74205】Re:Listbox間のドラッグアンドドロップ 亜矢 13/4/28(日) 15:47 質問
【74206】Re:Listbox間のドラッグアンドドロップ kanabun 13/4/28(日) 17:02 発言
【74212】エウレカ! 13/4/29(月) 7:18 発言
【74209】Re:Listbox間のドラッグアンドドロップ UO3 13/4/28(日) 21:54 発言
【74210】Re:Listbox間のドラッグアンドドロップ UO3 13/4/28(日) 21:58 発言
【74217】Re:Listbox間のドラッグアンドドロップ Abyss 13/4/29(月) 23:17 発言
【74219】Re:Listbox間のドラッグアンドドロップ kanabun 13/4/30(火) 9:26 発言
【74224】Re:Listbox間のドラッグアンドドロップ UO3 13/4/30(火) 14:33 発言
【74221】Re:Listbox間のドラッグアンドドロップ kanabun 13/4/30(火) 13:03 発言
【74222】Re:Listbox間のドラッグアンドドロップ kanabun 13/4/30(火) 13:17 発言
【74223】Re:Listbox間のドラッグアンドドロップ 亜矢 13/4/30(火) 14:24 質問
【74225】Re:Listbox間のドラッグアンドドロップ UO3 13/4/30(火) 15:23 発言
【74226】Re:Listbox間のドラッグアンドドロップ Abyss 13/4/30(火) 18:23 発言
【74227】Re:Listbox間のドラッグアンドドロップ Abyss 13/4/30(火) 19:32 発言
【74232】Re:Listbox間のドラッグアンドドロップ 亜矢 13/5/1(水) 3:23 質問
【74233】Re:Listbox間のドラッグアンドドロップ kanabun 13/5/1(水) 9:01 発言
【74234】Re:Listbox間のドラッグアンドドロップ 亜矢 13/5/1(水) 9:09 発言
【74237】Re:Listbox間のドラッグアンドドロップ kanabun 13/5/1(水) 10:32 発言
【74236】Re:Listbox間のドラッグアンドドロップ UO3 13/5/1(水) 9:37 発言
【74238】Re:Listbox間のドラッグアンドドロップ Abyss 13/5/1(水) 12:11 発言
【74258】Re:Listbox間のドラッグアンドドロップ 亜矢 13/5/8(水) 19:56 お礼

8084 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free