| |
▼亜矢 さん：
おはようございます
>Listboxの３つの内の一つに最初にデータが
>存在していない時にデータの無いListBoxに移動させるとエラーとなることがわかりました
いつもエラーになりますか？ あるいは【ゆっくり】操作をした時もエラーになりますか？
こちらの環境で、Abyssさんのコードにしろ、私のコートにしろ、１つのリストボックスに
リストを設定せずに動かしてみていますが、ドロップしても移動しないという現象はあるものの
エラーにはなっていません。
実は、私のコードで、最初に、ドラッグ＆ドロップを【早く】操作したときに、エラーになる
現象がありました。
素人考えですが、
A処理コード
B処理コード
この時、
１．A処理が非常に早くおわってB処理コードが実行されるとき、あまりにも早くて
その時点では、VBAが、A処理の結果を取り込めていないのでエラー。
２．A処理が非常に遅くて、実際には処理完了していないのにB処理が実行されてエラー
こんなケースが時々発生しました。で、【困った時のDoEvent】を A処理コードと
B処理コードの間にいれて回避したりしています。
ちゃんとした原因についてはAByssさんから回答があるとは思いますが。
で、
>List内での移動ができるようにしたいと思います
こちらについては、私が最初に、【同一リストボックス】での処理をスキップする
コードをご提示して、AByssさんも、それをわざわざ組み込まれたんだと思います。
ですから、そのスキップ処理をなくせば、実現はすると思います。
ただし、そういうことを想定していないコードですので、実行すると、あれ？
もっと、こういうようにしたいなといったことがでてくると思います。
AByssさんが、すでに、
>その他にもいろいろ要望があると思いますよ。ドラッグ状態でスクロールしたいとか
と書いておられるようなポイントが、おそらくは追加で希望されるんじゃないかと。
現在のコードでは、リストの更新は私のコードにしろ、AByssさんのコードにしろ
BeforeDropOrPaste でのみ行っているわけですが、運用面を考えますと
BeforeDragOverでも、なんらかのリストの更新が必要になってくるような気がします。
もう用済みでしょうが、私のコードに同一リストボックス内での移動を追加しました。
（それのみの対応ですから、その結果、あれ？というところも、でてきますが）
新規ブックでこれを動かしてみられて、あぁ、ここを、こうしたいというところが
２つ、３つでてくると思われますので、それを確認されたうえで、要件提示をして、
あらためて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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
