Excel VBA質問箱 IV

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

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


8074 / 76732 ←次へ | 前へ→

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

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