Excel 用户窗体导致次要问题

Excel 用户窗体导致次要问题

我有一个带有 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 工作簿时,我才发现问题。除非我先关闭此工作簿,否则新工作簿不会打开。我相信这是一个等待某事的操作,但看不到是什么。

相关内容