Excel VBA質問箱 IV

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

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


1469 / 13646 ツリー ←次へ | 前へ→

【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 お礼[未読]

【74193】Listbox間のドラッグアンドドロップ
質問  亜矢  - 13/4/27(土) 20:52 -

引用なし
パスワード
   いつもお世話になります。
ユーザーフォームにListボックスが5ヶあります。
 Listboxは複数列が表示されています。
 Listbox1
   AA BB CC DD
   XX YY ZZ HH
 Listbox2
   VV RR GG UU
   JJ KK LL PP
 Listbox3
   TT WW SS OO
   NN MM TT CC
 他は同じ様になっている
  ここでListbox1 の AA BB CC DD の行をドラッグアンドドロップして
  Listbox3のTT WW SS OOのところで離すと
 Listbox1は
   XX YY ZZ HH
 Listbox2は変わらず
 Listbox3 は
   AA BB CC DD
   TT WW SS OO
   NN MM TT CC
  の様にしたいと思います
  どのListboxからも自由にドラッグアンドドロップができることが必要です。
  1列だけの場合は他のレスで何とかできるようになりましたが、
  複数列の場合はどのようにしたら行のデータを取得したらよいかわかりません。
  参考になるコードがありましたら、教えて頂きたいと思います。
 よろしくお願いします。


  

【74195】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/4/27(土) 21:29 -

引用なし
パスワード
   ▼亜矢 さん:こんにちは〜

参考リンクだけですけど、

mougの即効テクニックに こんなのがあります。
■ドラッグ&ドロップ−ListBox⇒ListBox
ht tp://www.moug.net/tech/exvba/0150045.html

他には
■ユーザーフォームのリストボックスでドラッグ&ドロップ
ht tp://www2.aqua-r.tepm.jp/~kmado/ke_m16.htm#E03M158

【74197】Re:Listbox間のドラッグアンドドロップ
質問  亜矢  - 13/4/28(日) 4:30 -

引用なし
パスワード
   ▼kanabun さん:
>▼亜矢 さん:こんにちは〜
>
>参考リンクだけですけど、
>
>mougの即効テクニックに こんなのがあります。
>■ドラッグ&ドロップ−ListBox⇒ListBox
>ht tp://www.moug.net/tech/exvba/0150045.html
>
>他には
>■ユーザーフォームのリストボックスでドラッグ&ドロップ
>ht tp://www2.aqua-r.tepm.jp/~kmado/ke_m16.htm#E03M158
上記の2点はすでにチェック済みでした。
 結局Listboxが1列だけが取得されています。
 今考えているのは10列のリストボックスでリストボックスで行を選択したときに
 その10列そのものが移動してほしいことなのです。
 よろしくお願いします。

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

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

> 上記の2点はすでにチェック済みでした。
> 結局Listboxが1列だけが取得されています。
> 今考えているのは10列のリストボックスで

モーグのサンプルのListBox2_BeforeDropOrPasteに入った時点で、
ListBox1.ListIndex には、どの行が選ばれていたかのインデックスが
入っていますよね。
それを元に、今、AddItemした行のリスト項目をセットしてやればいかがでしょう。

【74199】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/4/28(日) 8:31 -

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

>>参考リンクだけですけど、
>>
>>mougの即効テクニックに こんなのがあります。
>>■ドラッグ&ドロップ−ListBox⇒ListBox
>>ht tp://www.moug.net/tech/exvba/0150045.html

> 上記の2点はすでにチェック済みでした。

> 結局Listboxが1列だけが取得されています。
> 今考えているのは10列のリストボックスでリストボックスで行を選択したときに
> その10列そのものが移動してほしいことなのです。

そういうことでしたか、それは失礼しました。
いま問題になっていることは主として2つの点だと思います。

1. 1列目だけでなく、10列一括して移動したい。
2. ドロップした位置に挿入したい

そこで、(きょうはちょっと時間がないので)
1.のほうだけ
mougの参考ページをアレンジしながら、
ListBox1から 任意のアイテムを ListBox2 の先頭アイテムに
追加する 処理だけ、編集してみます。

修正内容は
DataObjectにクリップするとき、列データをTABコードを
区切り記号として連結した文字列を送り、
ListBox2でドロップするとき、 DataObjectの文字列を
TABで列に分解して 0番アイテムに挿入する。
ということです。

Private Sub UserForm_Initialize()
  With ListBox1
    .List = Range("A1:D10").Value
    .ColumnCount = 4
    .ColumnWidths = "20;20;20;20"
  End With
  With ListBox2
    .List = Range("A11:D26").Value
    .ColumnCount = 4
    .ColumnWidths = "20;20;20;20"
  End With
  
End Sub


'○リストボックス1のマウス移動時イベント(ドラッグ開始)
Private Sub ListBox1_MouseMove _
  (ByVal Button As Integer, ByVal Shift As Integer, _
  ByVal X As Single, ByVal Y As Single)
  'マウス左ボタンのドラッグ時に対応
  If Button <> 1 Then Exit Sub
  'データオブジェクトに現在の選択地を格納
  Dim i As Long
  With ListBox1
    ReDim ss(.ColumnCount - 1)
    For i = 0 To .ColumnCount - 1
      ss(i) = .List(.ListIndex, i)
    Next
  End With
  With New DataObject
    .SetText Join(ss, vbTab)
    .StartDrag 'ドラッグ開始
  End With
End Sub


'○リストボックス2へのドラッグ(In) ----- 無修正
Private Sub ListBox2_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継続
Cancel = True

End Sub


'○リストボックス2へのドロップ
Private Sub ListBox2_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 Action = fmActionDragDrop Then
    ss = Split(Data.GetText(), vbTab)
    
    With ListBox2
      .AddItem ss(0), NewIndex
      For i = 1 To UBound(ss)
        .List(NewIndex, i) = ss(i)
      Next
      .TopIndex = 0
    End With
  End If
  Data.Clear 'DataObjectのデータクリア

End Sub

ListBox2でマウスをドロップした位置へ AddItem する方法は
ListBox2のうえを MouseMove するとき X,Y座標が得られますので、
それを「一行の行間を含む高さ」で除してやれば .ListIndex が
得られるので、これを使います。

【74202】Re:Listbox間のドラッグアンドドロップ
発言  亜矢  - 13/4/28(日) 12:25 -

引用なし
パスワード
   ▼kanabun さん:
>▼亜矢 さん:
>
>>>参考リンクだけですけど、
>>>
>>>mougの即効テクニックに こんなのがあります。
>>>■ドラッグ&ドロップ−ListBox⇒ListBox
>>>ht tp://www.moug.net/tech/exvba/0150045.html
>
>> 上記の2点はすでにチェック済みでした。
>
>> 結局Listboxが1列だけが取得されています。
>> 今考えているのは10列のリストボックスでリストボックスで行を選択したときに
>> その10列そのものが移動してほしいことなのです。
>
>そういうことでしたか、それは失礼しました。
>いま問題になっていることは主として2つの点だと思います。
>
>1. 1列目だけでなく、10列一括して移動したい。
>2. ドロップした位置に挿入したい
>
>そこで、(きょうはちょっと時間がないので)
>1.のほうだけ
ありがとうございました。
 挿入(先頭行)へは提示頂いたコードでうまくいきました。
 2.のドロップした位置への挿入についてはまだ、解決されていませんので、
  引き続きご指導の程よろしくお願いします。

【74203】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/4/28(日) 12:26 -

引用なし
パスワード
   あさにレスした
> 1. 1列目だけでなく、10列一括して移動したい。
のコードに、さらに
>2. ドロップした位置に挿入したい 1. コードに
を加えてみました。
ただし、いろいろ簡略化のために決め打ちしているところが
ありますので、適宜そちらの環境に修正してください。

a) ListBoxは ListBox1とListBox2 だけを使い、
 方向は ListBox1 でDrag開始して、 ListBox2 へのDropだけ
 に限定している。
b) ListBoxへのListのセットはシートのA〜Dの4列をセットしている

c) 一行の高さを変数TextHiに求めているが
>  TextHi = lngHeight * 72 / 96  'DPI 決め打ち
コメントにあるように、DPI を 96 に決め打ちしている。
 ここは APIを使って 96 を求めたほうがよい。
 また、ListBox1 と ListBox2 で使用しているFont は 同じと仮定。

'-----------------------------------
Option Explicit

Private TextHi As Long 'ListBox リストの一行の高さ(全ListBox共通)

'//ユーザフォーム初期化
Private Sub UserForm_Initialize()
  Dim acc As IAccessible
  Dim lngHeight As Long
   
  'ListBoxに初期リストのセット
  With ListBox1
    .List = Range("A1:D10").Value
    .ColumnCount = 4
    .ColumnWidths = "20;20;20;20"
  End With
  With ListBox2
    .List = Range("A11:D26").Value
    .ColumnCount = 4
    .ColumnWidths = "20;20;20;20"
  End With
  
  '一行の高さをListBox1から得る
  Set acc = ListBox1
  acc.accLocation 0&, 0&, 0&, lngHeight, 1&
  TextHi = lngHeight * 72 / 96  'DPI 決め打ち
  
End Sub


'//ListBox1 ドラッグ開始
'// マウス左ボタンのドラッグ時に対応
Private Sub ListBox1_MouseMove _
  (ByVal Button As Integer, ByVal Shift As Integer, _
  ByVal X As Single, ByVal Y As Single)
  If Button <> 1 Then Exit Sub
  'DataObjectに現在の選択アイテム値(複数列)格納
  Dim i As Long
  With ListBox1
    ReDim ss(.ColumnCount - 1)
    For i = 0 To .ColumnCount - 1
      ss(i) = .List(.ListIndex, i)
    Next
  End With
  With New DataObject
    .SetText Join(ss, vbTab)
    .StartDrag 'ドラッグ開始
  End With
End Sub


'//ListBox2にマウスが入った時のイベント
Private Sub ListBox2_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継続
 Cancel = True

End Sub


'// ListBox2へのドロップ
Private Sub ListBox2_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 Action = fmActionDragDrop Then
    ss = Split(Data.GetText(), vbTab)
    With ListBox2
      NewIndex = .TopIndex + Y \ TextHi
      .AddItem ss(0), NewIndex
      For i = 1 To UBound(ss)
        .List(NewIndex, i) = ss(i)
      Next
      .TopIndex = NewIndex
    End With
  End If
  Data.Clear 'DataObjectのデータクリア

End Sub

【74204】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/4/28(日) 14:40 -

引用なし
パスワード
   >Private TextHi As Long 'ListBox リストの一行の高さ(全ListBox共通)

>Private Sub UserForm_Initialize()
>  Dim acc As IAccessible
>  Dim lngHeight As Long
>   
>  '一行の高さをListBox1から得る
>  Set acc = ListBox1
>  acc.accLocation 0&, 0&, 0&, lngHeight, 1&
>  TextHi = lngHeight * 72 / 96  'DPI 決め打ち
>  
>End Sub

リストの一行の高さ
VB6には ListBoxのTextHightプロパティというのがあって、
この値を直接取得できるのですが、VBAのUserForm の
ListBox にはこれがありません。
上で利用したIAccessible による方法以外に APIを使っていくつかの
手法で求めることができますが、そのことを教わった過去ログが
アーカイブに見つかりましたので参考までURLを紹介しておきます。

★//web.archive.org/web/20081006065032/★//www.moug.net/faq/viewtopic.php?t=15585

↑ ★印を 半角の HTTP: に置換してください。

【74205】Re:Listbox間のドラッグアンドドロップ
質問  亜矢  - 13/4/28(日) 15:47 -

引用なし
パスワード
   ▼kanabun さん:
 早速のご指導ありがとうございました。
>あさにレスした
>  '一行の高さをListBox1から得る
>  Set acc = ListBox1
>  acc.accLocation 0&, 0&, 0&, lngHeight, 1&
   ↑
  ここでエラーがでました。
 修正する方法を教えて頂きたいと思います。
 よろしくお願いします。

【74206】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/4/28(日) 17:02 -

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

>>  '一行の高さをListBox1から得る
>>  Set acc = ListBox1
>>  acc.accLocation 0&, 0&, 0&, lngHeight, 1&
>   ↑
>  ここでエラーがでました。
> 修正する方法を教えて頂きたいと思います。

何というエラーメッセージですか?


ListBox1 にリストを設定してからでないと、

「実行時エラー '5':
プロシージャの呼び出し、または引数が不正です。」
というエラーが出ます。

直前で紹介した過去ログの 該当部分の shiraさんのご発言には
こうあります。

> また、リストボックスに項目が1つ以上存在している
> (あるいは一時的にでもそういう状態にする)
> という条件付きなら、
> 下記のようにIAccessibleを利用して取得するのも
> お手軽ですね。
>
>  Dim acc As IAccessible
>  Dim lngHeight As Long
>  Set acc = Me.ListBox1
>  acc.accLocation 0&, 0&, 0&, lngHeight, 1&
>  MsgBox lngHeight ' ピクセル単位

【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

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

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

↑ 移動後の元リストの選択解除が時々うまくいかないようです。
ちょっと調べてみます。

【74212】エウレカ!
発言    - 13/4/29(月) 7:18 -

引用なし
パスワード
   こんにちは。お邪魔します。

すみません、回答ではありません。まったく回答ではありません。
積年の謎が解けて嬉しいという、それだけの書込です。

>>  Dim acc As IAccessible
>>  Dim lngHeight As Long
>>  Set acc = Me.ListBox1
>>  acc.accLocation 0&, 0&, 0&, lngHeight, 1&
>>  MsgBox lngHeight ' ピクセル単位

つねづね、IAccessibleってなんかよくワカラナイ、とモヤモヤしていたのですが
このコードを見て、ストンと腑に落ちました。

テキトーにオブジェクトを放り込めば、そのオブジェクトのプロパティを
拡大してくれる(かのように働く) 便利ツール・オブジェクト ですね。
たとえると、カブトコウジがマジンガーゼットに乗るとぐーんとパワー・
アップするみたいな。

ああ、雑い理解なのは承知しています。
それでもとにかく本質をつかんでしまえばこっちのものです。
厳密には、本質をつかんだような気分になってしまえば、です。
とにかく最初の足がかりができました。


亜矢さん、本当にお邪魔さまでした。
ほかのみなさまにも ごきげんよう。では。

【74217】Re:Listbox間のドラッグアンドドロップ
発言  Abyss  - 13/4/29(月) 23:17 -

引用なし
パスワード
   今回のケースなら、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

【74219】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/4/30(火) 9:26 -

引用なし
パスワード
   ▼Abyss さん:
いつもありがとうございます

>今回のケースなら、IAccessibleのaccHitTestメソッドで
>indexを取得する方法が簡単だと思います。
>kanabunさんのご紹介掲示板でshiraさんも
>そのような方法を提示してます。

当時は GetTextExtentPoint32 API がこういうときにも使えるとの
shiraさんからのレスに「舞い上がっていた」ので、ListBoxのTextHeight
取得のための紹介下さった他の方法、あまり検証してませんでしたが、
そうですか、あのスレではそういうことにも言及があったんですねぇ

>accHitTestメソッドの利用なら割と簡単に
>操作が可能になります。

なるほど、こういうときに accHitTest で調べれるんですね、
勉強になります。
ほかにも いつかパクリたくなるアイデアいっぱいです。

>  With New DataObject
>    .SetText ObjPtr(Me)
>    .StartDrag
>  End With


>  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


>  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

【74221】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/4/30(火) 13:03 -

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

> Listbox1 の AA BB CC DD の行をドラッグアンドドロップして
> Listbox3のTT WW SS OOのところで離すと
> Listbox1は
>   XX YY ZZ HH
> Listbox3 は
>   AA BB CC DD
>   TT WW SS OO
>   NN MM TT CC
>  の様にしたいと思います

Abyss さんのコードでいろいろ遊んでいて気が付いたのですが、
Drag & Drop先の現在のリストの一番下に追加移動する方法がないですね。
(選択行の上側に挿入なので)
そういうケースも考えて 同一ListBoxのなかで 移動が自由にできると
いいですね。(そうすれば、並び替えもできるので)

【74222】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/4/30(火) 13:17 -

引用なし
パスワード
   リストボックスのリストが

 AA BB CC DD
 TT WW SS OO
 NN MM TT CC

とあるとき、各アイテムの一行の高さの 半分より 上でドロップされたら、
そのアイテムの「上」に挿入、
下半分でドロップされたら、そのアイテムの「下」に挿入、
とする手もありますか?
そうすれば 一番下のアイテムの下のほうでドロップして、

 NN MM TT CC  ← ここより下でドロップする

「最終行に追加」することが可能となりますね。

【74223】Re:Listbox間のドラッグアンドドロップ
質問  亜矢  - 13/4/30(火) 14:24 -

引用なし
パスワード
   ▼kanabun さん:
>リストボックスのリストが
>
> AA BB CC DD
> TT WW SS OO
> NN MM TT CC
>
>とあるとき、各アイテムの一行の高さの 半分より 上でドロップされたら、
>そのアイテムの「上」に挿入、
>下半分でドロップされたら、そのアイテムの「下」に挿入、
>とする手もありますか?
>そうすれば 一番下のアイテムの下のほうでドロップして、
>
> NN MM TT CC  ← ここより下でドロップする
>
>「最終行に追加」することが可能となりますね。
みなさんに色々お手数をお掛けしています。
 いままでのコートでだいたいとのところは処理可能になっていますが、
 もう一つ、移動や、挿入の時に選択状態がわかるようにして頂ければ
 と思います。
 たとえばListbox1からList2へドラッグアンドドロップする際に
 Listbox2の先頭行から下のほうへマウスが移動するときに選択行が色づけ(選択されている状態)がされていると、今どの行へ移動中なのかがわかるので、
 できればそういう方法でお願いします。
 よろしくお願いします。

【74224】Re:Listbox間のドラッグアンドドロップ
発言  UO3  - 13/4/30(火) 14:33 -

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

Abyssさん

いつも、素晴らしいコードを見せていただき、ありがとうございます。
同じクラス処理をしても(当然ですが)コードの中身は、小学生低学年と大人の差が歴然ですね!

へぇ!とか、なるほど!とか、そういったところも少しはありますが、ほとんどが
わからないけど、動かすと、ちゃんと参照ができてる! というものです。
でも、これをラッパーのように使って、とにかく使えるんだと、そういった部品を、今回アップされた
コートの中から、いくつも、作っておけそうです。

で、私がアップしたクラス、小学生レベルなんですが、Abyssさんのコードでやっておられる
各処理のタイミングもパクらせていただき、Abysさんのコードをと同じように
・転記先では リストトップにもっていかず、そのままの位置で、挿入されたということを
 明確にするために選択状態に。
・転記元の選択状態のリセットは、リストからデータを削除するのと同じタイミングで。
 (考えてみれば、これはあたりまえでしたね)

という部分のみ、コード修正。(myLB_BeforeDropOrPaste をリバイスです)

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
        .ListIndex = NewIndex
      End With
    End If
    LB.RemoveItem IDX    '移動元リストボックスから削除
    LB.ListIndex = -1    '移動元の選択状態をリセット
  End If
 
  Data.Clear 'DataObjectのデータクリア
  
End Sub

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

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

Abyssさんのコードで対応いただいたほうが、ずっと完成度も高いのですが
私の小学生レベルのコードで言えば、myLB_BeforeDragOver を以下にすれば
大丈夫かもしれません。

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継続
  If Not myLB Is LB Then
    With myLB
      If Y = 0 Then
        myLB.ListIndex = -1
      Else
        myLB.ListIndex = .TopIndex + Y \ getRowHeight
      End If
    End With
  End If
End Sub

【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

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

引用なし
パスワード
   API関数宣言部分に「PtrSafe」キーワードが
残ったままですね。適当に削除してください。

【74232】Re:Listbox間のドラッグアンドドロップ
質問  亜矢  - 13/5/1(水) 3:23 -

引用なし
パスワード
   ▼Abyss さん:
>API関数宣言部分に「PtrSafe」キーワードが
>残ったままですね。適当に削除してください。
ありがとうございます。私も64ビット対応でPtrSafeを使用しています。
 プログラムは完璧でした。
 最後にもう一つお願いがあります。List内での移動ができるように
 したいと思います。題名とは違いますが、こちらの方もお願いできますでしょうか。
 お手数をお掛けしますが、よろしくお願いします。
 ※提示して頂いたプログラムでListboxの3つの内の一つに最初にデータが
 存在していない時にデータの無いListBoxに移動させるとエラーとなることがわかりました。

【74233】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/5/1(水) 9:01 -

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


> List内での移動ができるように

前のぼくの発言 → Listの最終行のつぎにアイテムを追加もできるように

亜矢さんのほうでは ↑こういう処理は必要ないですか?
いつもカーソルのある行「の上に」挿入で済んでいますか?

【74234】Re:Listbox間のドラッグアンドドロップ
発言  亜矢  - 13/5/1(水) 9:09 -

引用なし
パスワード
   ▼kanabun さん:
>▼亜矢 さん:
>
>
>> List内での移動ができるように
>
>前のぼくの発言 → Listの最終行のつぎにアイテムを追加もできるように
>
>亜矢さんのほうでは ↑こういう処理は必要ないですか?
>いつもカーソルのある行「の上に」挿入で済んでいますか?

いつもお世話になります。Listの最終行のつぎにアイテムを追加もできるように
  ↑
 できればそのように出来れば一番いいです。
 よろしくお願いします。いまは最終行の上に入れています。
 最終行にしたい場合は最終行を一度他のListboxへ入れて
 戻して行っています。 

【74236】Re:Listbox間のドラッグアンドドロップ
発言  UO3  - 13/5/1(水) 9:37 -

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

おはようございます

>Listboxの3つの内の一つに最初にデータが
>存在していない時にデータの無いListBoxに移動させるとエラーとなることがわかりました

いつもエラーになりますか? あるいは【ゆっくり】操作をした時もエラーになりますか?
こちらの環境で、Abyssさんのコードにしろ、私のコートにしろ、1つのリストボックスに
リストを設定せずに動かしてみていますが、ドロップしても移動しないという現象はあるものの
エラーにはなっていません。

実は、私のコードで、最初に、ドラッグ&ドロップを【早く】操作したときに、エラーになる
現象がありました。

素人考えですが、

A処理コード
B処理コード

この時、

1.A処理が非常に早くおわってB処理コードが実行されるとき、あまりにも早くて
  その時点では、VBAが、A処理の結果を取り込めていないのでエラー。
2.A処理が非常に遅くて、実際には処理完了していないのにB処理が実行されてエラー

こんなケースが時々発生しました。で、【困った時のDoEvent】を A処理コードと
B処理コードの間にいれて回避したりしています。
ちゃんとした原因についてはAByssさんから回答があるとは思いますが。

で、

>List内での移動ができるようにしたいと思います

こちらについては、私が最初に、【同一リストボックス】での処理をスキップする
コードをご提示して、AByssさんも、それをわざわざ組み込まれたんだと思います。
ですから、そのスキップ処理をなくせば、実現はすると思います。
ただし、そういうことを想定していないコードですので、実行すると、あれ?
もっと、こういうようにしたいなといったことがでてくると思います。

AByssさんが、すでに、

>その他にもいろいろ要望があると思いますよ。ドラッグ状態でスクロールしたいとか

と書いておられるようなポイントが、おそらくは追加で希望されるんじゃないかと。
現在のコードでは、リストの更新は私のコードにしろ、AByssさんのコードにしろ
BeforeDropOrPaste でのみ行っているわけですが、運用面を考えますと
BeforeDragOverでも、なんらかのリストの更新が必要になってくるような気がします。

もう用済みでしょうが、私のコードに同一リストボックス内での移動を追加しました。
(それのみの対応ですから、その結果、あれ?というところも、でてきますが)
新規ブックでこれを動かしてみられて、あぁ、ここを、こうしたいというところが
2つ、3つでてくると思われますので、それを確認されたうえで、要件提示をして、
あらためてAByssさんのコードでの対応をお願いすればいかがでしょう。
(私も、自分の勉強のために、私のコードでの改訂もやってみますが)

なお、各リストへのテストデータの設定、私のコードではシートから転記していましたが
面倒なので、その部分はAByssさんのテストデータ埋め込みコードを流用しています。

【標準モジュール】

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

【ユーザーフォームモジュール】

Option Explicit

Dim cPool(2) As Class1

Private Sub UserForm_Initialize()
  Dim e
  Dim SS$
  Dim i As Long
  Dim j As Long
  Dim z As Long
  Dim arr(9, 3) As String
  
  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
    Set cPool(z) = New Class1
    cPool(z).Generate e
    
    z = z + 1
  
  Next
 
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Erase cPool
End Sub

【クラスモジュール】

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継続
'  If Not myLB Is LB Then   '★同一リストボックスの回避をやめる
    With myLB
      If Y = 0 Then
        myLB.ListIndex = -1
      Else
        myLB.ListIndex = .TopIndex + Y \ getRowHeight
      End If
    End With
'  End If           '★同一リストボックスの回避をやめる
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
        .ListIndex = NewIndex
      End With
    End If
    LB.RemoveItem IDX    '移動元リストボックスから削除
    LB.ListIndex = -1    '移動元の選択状態をリセット
'  End If               '★同一リストボックスの回避をやめる
 
  Data.Clear 'DataObjectのデータクリア
  
End Sub

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


【ユーザーフォームモジュール】

Option Explicit

Dim cPool(2) As Class1

Private Sub UserForm_Initialize()
  Dim e
  Dim SS$
  Dim i As Long
  Dim j As Long
  Dim z As Long
  Dim arr(9, 3) As String
  
  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
    Set cPool(z) = New Class1
    cPool(z).Generate e
    
    z = z + 1
  
  Next
 
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
  Erase cPool
End Sub

【74237】Re:Listbox間のドラッグアンドドロップ
発言  kanabun  - 13/5/1(水) 10:32 -

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

>> Listの最終行のつぎにアイテムを追加もできるように
>>  ↑
> できればそのように出来れば一番いいです。

あるいはいっそどれかの列で リストをSortして表示するように
しておくとか?
そうすれば、同じListBox内での移動は不要になります。最終行に
AddItemも(結果として)可能になります。

【74238】Re:Listbox間のドラッグアンドドロップ
発言  Abyss  - 13/5/1(水) 12:11 -

引用なし
パスワード
   > List内での移動ができるように

基本の考え方は同じです。
が、一つ、上下移動になるので、
それぞれのタイミングでのListIndex変化に注意すべきです。

それから、選択状態も維持したいなら、
ListBox内での移動の場合、StartDragメソッドが
ListIndexを所有してますので、OnTimeメソッドとかの
Timerを使う必要が生じますね。

【74258】Re:Listbox間のドラッグアンドドロップ
お礼  亜矢  - 13/5/8(水) 19:56 -

引用なし
パスワード
   ▼Abyss さん:
>亜矢さん
>
>その他にもいろいろ要望があると思いますよ。
>ドラッグ状態でスクロールしたいとか、kanabunさんの
>ご指摘のように、当ListBox中での並び替えなど。
>
>> 選択行が色づけ(選択されている状態)がされていると、
>> 今どの行へ移動中なのかがわかるので、....
>
>APIの場合でしたらDrawInsert関数で矢印を付ける事が
>可能ですが、UserformのListBoxには効果がないようです。
>
>前回の提案コードから、いくつかの無駄を修正するついでに
>今回の条件を取り入れてみました。
>お試しください。
>
># UO3さん、ご感想ありがとうございます。
># 勝手ながらUO3さんのアイディアを使わせて頂いてます。
>
連休中はご無沙汰してすみませんでした。
 本日関係者と相談の結果、List内の移動は不要との結論になりましたので、
 Abyss さんから提示されたプログラムでOKということになりました。
 色々な関係者からの親切なプログラムの提示を頂き感謝です。
 これをもってこの件を終了とさせて頂きます。
 本当にありがとうございました。
 

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