Excel VBA 使用 .OnAction 方法的用户窗体列表框动态上下文菜单

Question

我为 Userform Listbox.

构建了一个动态上下文菜单

在这个Listbox中是一系列文件。我的目标是当您右键单击一个文件时，会弹出一个包含文件夹位置列表的上下文菜单。左键单击这些文件夹位置之一会将文件复制到该位置。

我将使用.CopyFile(Location, Destination, [Overwrite])方法来做到这一点。

我在为每个 Item 添加的事件动态分配 .OnAction 事件时遇到困难。

Userform 模块代码

Option Explicit
Private Const mCONTEXT_MENU_NAME = "myRightClickListbox"
Private m_clsContextMenu As CContextMenu

'Function mySendTo(fName As String)
    'MsgBox fName
'End Function

Sub mySendTo(fName As String)
    MsgBox fName
End Sub

Private Sub ListBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Dim myString As String: myString = "C:\myFolder\"
Dim FolderName As String: FolderName = Dir("C:\myFolder\", vbDirectory)    

If Button = 2 Then
        '*\Listbox right click context menu
        On Error Resume Next
        Application.CommandBars(mCONTEXT_MENU_NAME).Delete 'remove any previous instance
        On Error GoTo 0

        Set m_clsContextMenu = New CContextMenu

        With CommandBars.Add(mCONTEXT_MENU_NAME, Position:=msoBarPopup)
            With .Controls.Add(Type:=msoControlPopup, before:=1, temporary:=True)
                .Caption = "Send to"

                i = 0
                Do While FolderName <> ""
                    If FolderName <> "." And FolderName <> ".." Then
                        If (GetAttr(myString & FolderName) And vbDirectory) = vbDirectory Then
                            i = i + 1
                            With .Controls.Add(Type:=msoControlButton, before:=i, temporary:=True)
                                .FaceId = 23
                                .Caption = FolderName
                                .Tag = "t" & FolderName
                                .OnAction = "'mySendTo " & FolderName & "'"
                                '.OnAction = "=mySendTo(" & FolderName & ")"
                                '.Parameter = FolderName
                            End With
                        End If
                    End If
                    FolderName = Dir()
                Loop
            End With

            Set m_clsContextMenu.LBox = Me.ListBox1
        End With
        '*//
    End If
End Sub

Class 模块代码 CContextMenu

Public LBox As MSForms.ListBox

上面的代码成功地为 Userform Listbox 创建了一个右键单击激活的上下文菜单，它由一个子菜单 Type:=msoControlPopup 组成，其中包含每个文件夹的 Items指定的 FolderName 目录。

我正在尝试为每个创建的 Item 动态分配 .OnAction 事件以调用 mySendTo Sub 或 Function。我被告知您只能以这种方式按名称调用 Functions，并且使用它自己的参数调用 Sub 将会失败。 None 我尝试的越少，似乎都不起作用。尽管两者都触发了 Error: 400，这意味着 Excel 正在尝试调用该事件。

这两个事件都触发 MsgBox 显示参数 String（为了简单起见，我已经这样做了，直到我知道代码运行正确）。

重要的是，当单击子菜单中的每个 Item 时，它会触发引用特定 Item.Caption 文本的代码 - 在在这种情况下，FolderName 目录（本身的位置）中的子文件夹名称。

我打算将文件从 Listbox 复制到上下文子菜单 Item 指示的新目标文件夹。

我知道我的 .OnAction 语法很接近了，但这是否是因为我误用了我的 Sub / Function 参数调用事件，或者因为我我还尝试将 .OnAction 事件动态分配给一个已经动态创建的上下文子菜单 Item，我就是想不出来。

如果将上面的代码粘贴到一个空白的 Userform 模块中并添加一个名为 "ListBox1" 的 Listbox，您应该有一个可用的右键单击激活的上下文菜单和一个子菜单.

如果您尝试单击其中一个 Items，您应该还会收到 Error: 400。

关于如何将动态 Sub 或 Function 传递给每个 Item 并且参数是它自己的 .Caption 的任何帮助将是 非常感谢，再次感谢您的宝贵时间。

先生J

Answer 1

将所有 OnAction 设置为不带参数的 public Sub。然后在该 Sub 中，使用 Application.CommandBars.ActionControl 获取触发事件的特定命令栏项目。然后，您可以获得命令栏项目的属性，用于标识您正在处理的项目。 .Parameter 属性是最好的选择。

在您的情况下，我想您可以只使用标题属性...但这很危险，因为您稍后可能会决定对其进行格式化、截断或其他任何操作。因此，请确保将命令项的参数字段设置为有问题的文件夹（您的代码中已有该文件夹 - 但已注释掉）。

所以在你的原始代码中：

With .Controls.Add(Type:=msoControlButton, before:=i, temporary:=True)
  .Caption = FolderName
  'etc etc
  .OnAction = "'MyWorkbookName.xlsx'!mySendTo"
  .Parameter = FolderName
End With

顺便说一句，始终在 .OnAction 中指定完全限定的宏名称。我通过艰苦的经历学会了这一点。确保始终将工作簿名称放在单引号中，就像我上面的那样。（引号并不总是需要的，但经常是......而且总是有它并没有什么坏处。）

然后在您的事件处理程序中：

Public Sub mySend()
  Dim sourceFolder as String

  On Error resume Next
  sourceFolder = Application.CommandBars.ActionControl.Parameter
  On Error goto 0

  if sourceFolder <> "" Then GoOnAndDoWhatever(sourceFolder)
End Sub

Excel VBA 使用 .OnAction 方法的用户窗体列表框动态上下文菜单

Excel VBA Userform Listbox Dynamic Context Menu Using .OnAction Method

excel

vba

contextmenu

dynamic

userform