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

Question

我为 Userform 构建了一个动态上下文菜单Listbox .

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

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

我很难动态分配 .OnAction每个 Item 的事件添加。
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 中的每个文件夹目录。

我正在尝试动态分配 .OnAction每个 Item 的事件创建调用 mySendTo Sub或 Function .有人告诉我，您只能调用 Functions以这种方式按名称和调用 Sub使用它自己的参数将失败。尽管如此，我都尝试过，但似乎都不起作用。虽然两者都触发了 Error: 400这意味着 Excel 正在尝试调用该事件。

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

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

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

我知道我和我的 .OnAction 关系密切语法，但是否是因为我误用了我的 Sub/ Function使用参数调用事件，或者因为我也在尝试动态分配 .OnAction事件到已经动态创建的上下文子菜单 Item ，我只是无法为我的生活弄明白。

如果将上面的代码粘贴到空白 Userform模块并添加 Listbox命名为“ListBox1”，您应该有一个带有子菜单的右键单击激活上下文菜单。

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

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

J先生

Answer 1

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

在您的情况下，您可以只使用我想的 Caption 属性......但这很危险，因为您以后可能会决定对其进行格式化，或截断它，或其他任何方式。因此，请确保将命令项的 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