我有一个带有 5 个列表框的用户表单,这些列表框包含用于填充各种文本框的列表,用于组织车辆、驾驶员和负载。总共有 235 个文本框。我更改了在这里关于使用拖放。但是我做了一些更改,当我尝试关闭工作簿时,它给了我一个蓝色圆圈,45 分钟后它仍然在那里。我删除了所有更改并使用了基本代码,但仍然导致问题。我必须进入任务管理器并物理停止该过程,但我看不到导致问题的原因。
这是用户表单的代码
Private Sub UserForm_Initialize()
Dim Ctrl As MSForms.Control
Dim LMB As ListBoxDragAndDropManager
Dim x As Integer
Set LBs = New Collection
For Each Ctrl In Me.Controls
If TypeName(Ctrl) = "ListBox" Then
Set LMB = New ListBoxDragAndDropManager
Set LMB.ThisListBox = Ctrl
LBs.Add LMB
End If
Next
For Each Ctrl In Me.Controls
If TypeName(Ctrl) = "TextBox" Then
Set LMB = New ListBoxDragAndDropManager
Set LMB.ThisTextBox = Ctrl
LBs.Add LMB
End If
Next
子目录结束
这是一个独立模块
Public DragSource As MSForms.ListBox
这是在类模块中
Option Explicit
Private WithEvents pThisListBox As MSForms.ListBox
Private WithEvents pThisTextBox As MSForms.TextBox
Friend Property Set ThisListBox(Ctrl As MSForms.ListBox)
Set pThisListBox = Ctrl
End Property
Friend Property Get ThisListBox() As MSForms.ListBox
Set ThisListBox = pThisListBox
End Property
Friend Property Set ThisTextBox(Ctrl As MSForms.TextBox)
Set pThisTextBox = Ctrl
End Property
Friend Property Get ThisTextBox() As MSForms.TextBox
Set ThisTextBox = pThisTextBox
End Property
Private Sub Class_Terminate()
Set DragSource = Nothing
Set pThisListBox = Nothing
End Sub
Private Sub pThisListBox_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As Long, _
ByVal Data As MSForms.DataObject, _
ByVal x As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Dim i As Long
If DragSource Is pThisListBox Then Exit Sub
Cancel = True
Effect = 1
pThisListBox.AddItem Data.GetText
With DragSource
For i = 1 To .ListCount
If .List(i - 1, 0) = Data.GetText Then
.RemoveItem i - 1
Exit For
End If
Next i
End With
End Sub
Private Sub pThisTextBox_BeforeDropOrPaste(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Action As Long, _
ByVal Data As MSForms.DataObject, _
ByVal x As Single, _
ByVal Y As Single, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Dim i As Long
If DragSource Is pThisListBox Then Exit Sub
Cancel = True
Effect = 1
pThisTextBox.Value = DragSource
With DragSource
For i = 1 To .ListCount
If .List(i - 1, 0) = Data.GetText Then
.RemoveItem i - 1
Exit For
End If
Next i
End With
End Sub
Private Sub pThisListBox_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, _
ByVal Data As MSForms.DataObject, _
ByVal x As Single, _
ByVal Y As Single, _
ByVal DragState As Long, _
ByVal Effect As MSForms.ReturnEffect, _
ByVal Shift As Integer)
Cancel = True
Effect = 1
End Sub
Private Sub pThisListBox_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal x As Single, _
ByVal Y As Single)
Dim MyDataObject As DataObject
Dim Effect As Integer
If Button = 1 Then
Set DragSource = pThisListBox
Set MyDataObject = New DataObject
If pThisListBox.Text = "" Then
Exit Sub
End If
MyDataObject.SetText pThisListBox.Value
Effect = MyDataObject.StartDrag
End If
End Sub
Private Sub pThisListBox_Click()
Dim Ctrl As MSForms.Control
Dim i As Integer
For Each Ctrl In ThisListBox.Parent.Controls
If Ctrl.Name <> ThisListBox.Name And TypeName(Ctrl) = "ListBox" Then
For i = 0 To Ctrl.ListCount - 1
Ctrl.Selected(i) = False
Next i
End If
Next Ctrl
End Sub
代码可以正常工作,并且可以更新文本框和列表框,没有任何问题,但当我关闭它时,或者当我尝试打开另一个 excel 工作簿时,我才发现问题。除非我先关闭此工作簿,否则新工作簿不会打开。我相信这是一个等待某事的操作,但看不到是什么。