| |
▼亜矢 さん：
横から失礼します。
kanabunさんのコードをそのまま借用し、ListBox1,2,3 それぞれ相互の移動にしてみました。
2つのリストボックス間の移動であれば、ユーザーフォームモジュールだけでも
問題なかったのですが、３つの「相互」ということになりますと、やや煩雑になりましたので
クラス処理にしてあります。なお、Initializeルーティンで各ListBoxのListに配列を
セットしているところは、こちらのテストコードですので、削除するか、あるいは実態にあわせて
変更してください。
（標準モジュール）
Option Explicit
Private Declare Function GetDC Lib "User32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32.dll" (ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Const LOGPIXELSX = 88
Const LOGPIXELSY = 90
Public LB As MSForms.ListBox
Public IDX As Long
'=================================================
' 値変換サブプロシジャ群
'=================================================
Function getRowHeight() As Long
Dim acc As IAccessible
Dim h As Long
Set acc = UserForm1.ListBox1
'ピクセル単位の行高を h に取得
acc.accLocation 0&, 0&, 0&, h, 1&
'ポイント単位に変換
getRowHeight = Y_pix2point(h)
End Function
Function Y_pix2point(px As Long) As Double
Dim PPI As Long
Dim DPI As Long
'水直方向・ピクセルをポイントへ変換
DPI = GetDPIY
PPI = GetPPI
Y_pix2point = Int(px * PPI / DPI)
End Function
Function GetPPI() As Long
GetPPI = Application.InchesToPoints(1)
End Function
Function GetDPIY() As Long
GetDPIY = GetDPI(LOGPIXELSY)
End Function
Private Function GetDPI(ByVal nFlag As Long) As Long
Dim hdc As Long
hdc = GetDC(Application.hWnd)
GetDPI = GetDeviceCaps(hdc, nFlag)
Call ReleaseDC(&H0, hdc)
End Function
（ユーザーフォームモジュール UserForm1）
Option Explicit
Dim cPool(1 To 3) As Class1
Private Sub UserForm_Initialize()
Set cPool(1) = New Class1
cPool(1).Generate ListBox1
Set cPool(2) = New Class1
cPool(2).Generate ListBox2
Set cPool(3) = New Class1
cPool(3).Generate ListBox3
With ListBox1
.List = Range("A1:C10").Value
End With
With ListBox2
.List = Range("D1:F10").Value
End With
With ListBox3
.List = Range("G1:I10").Value
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Erase cPool
End Sub
（クラスモジュール Class1）
Option Explicit
Dim WithEvents myLB As MSForms.ListBox
Sub Generate(ByVal listB As MSForms.ListBox)
Set myLB = listB
End Sub
Private Sub myLB_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
'DataObjectに現在の選択アイテム値（複数列）格納
Dim i As Long
If Button <> 1 Then Exit Sub
Set LB = myLB
With myLB
IDX = .ListIndex
ReDim ss(.ColumnCount - 1)
For i = 0 To .ColumnCount - 1
ss(i) = .List(IDX, i)
Next
End With
With New DataObject
.SetText Join(ss, vbTab)
.StartDrag 'ドラッグ開始
End With
End Sub
Private Sub myLB_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, _
ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True 'Drag&Drop継続
End Sub
Private Sub myLB_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As MSForms.fmAction, ByVal Data As MSForms.DataObject, _
ByVal X As Single, ByVal Y As Single, ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Dim ss
Dim i As Long
Dim NewIndex As Long
'同一リストボックス内でのドロップは無効
If Not myLB Is LB Then
'ドラッグ時のみドラッグされたデータをリスト項目に追加
If Action = fmActionDragDrop Then
ss = Split(Data.GetText(), vbTab)
With myLB
NewIndex = .TopIndex + Y \ getRowHeight
.AddItem ss(0), NewIndex
For i = 1 To UBound(ss)
.List(NewIndex, i) = ss(i)
Next
.TopIndex = NewIndex
End With
End If
LB.RemoveItem IDX '移動元リストボックスから削除
End If
Data.Clear 'DataObjectのデータクリア
LB.ListIndex = -1
End Sub
|
|
UO3
- 13/4/28(日) 21:54 -
