Excel VBA質問箱 IV

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

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


8104 / 76736 ←次へ | 前へ→

【74209】Re:Listbox間のドラッグアンドドロップ
発言  UO3  - 13/4/28(日) 21:54 -

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

横から失礼します。
kanabunさんのコードをそのまま借用し、ListBox1,2,3 それぞれ相互の移動にしてみました。
2つのリストボックス間の移動であれば、ユーザーフォームモジュールだけでも
問題なかったのですが、3つの「相互」ということになりますと、やや煩雑になりましたので
クラス処理にしてあります。なお、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

0 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 お礼

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