| |
今回のケースなら、IAccessibleのaccHitTestメソッドで
indexを取得する方法が簡単だと思います。
kanabunさんのご紹介掲示板でshiraさんも
そのような方法を提示してます。
UO3さんのclassアイディアもいいですね。
構造をお借りしてコードを作ってみました。
accHitTestメソッドの利用なら割と簡単に
操作が可能になります。
新規ブックのUserformにListBoxを三つ
用意し、下記コードを実行。
# ListIndexによる判別は問題がありましたので、再掲載です。
' *************
' （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 Function GetMessagePos& Lib "User32" ()
Private Declare 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!)
Dim ii%(1), acc As IAccessible
If Button <> vbKeyLButton Then Exit Sub
RtlMoveMemory ii(0), GetMessagePos()
Set acc = LBox
mIndex = acc.accHitTest(ii(0), ii(1)) - 1
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
Cancel = True
Effect = fmDropEffectMove
ptr = CLng(Data.GetText)
If ptr = ObjPtr(Me) Then
Effect = fmDropEffectNone: Exit Sub
End If
If Ptr2Cls(ptr).Index < 0 Then
Effect = fmDropEffectNone
End If
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 ii%(1), i As Long, NewIndex As Long
Dim fIndex As Long
Dim ptr As Long
Dim acc As IAccessible, mCls As Class1
Dim LBFrom As MSForms.ListBox
If Action <> fmActionDragDrop Then Exit Sub
ptr = CLng(Data.GetText)
If ptr = ObjPtr(Me) Then Exit Sub
Set mCls = Ptr2Cls(ptr)
fIndex = mCls.Index
If fIndex < 0 Then Exit Sub
Set acc = LBox
RtlMoveMemory ii(0), GetMessagePos()
NewIndex = acc.accHitTest(ii(0), ii(1)) - 1
Set LBFrom = mCls.Member
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
|
|
Abyss
- 13/4/29(月) 23:17 -
