| |
亜矢さん
その他にもいろいろ要望があると思いますよ。
ドラッグ状態でスクロールしたいとか、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
|
|
Abyss
- 13/4/30(火) 18:23 -
