复制并粘贴 activeX 按钮

Question

我有自定义右键单击菜单，当我单击子菜单项时，我想打开一个弹出窗口以允许用户输入目标或引用单元格以复制和粘贴父按钮 (activeX)

用户点击了“复制到”：

弹出式打开：允许用户选择工作表上的任何单元格或手动输入目标单元格参考。

当我点击“确定”按钮时，按钮的副本应该在E14

自定义菜单：

Sub RClickMenu()

Dim MenuItem As CommandBarPopup
Dim ListType As String
ListType = "Lists"

' Add the popup menu.
With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
     MenuBar:=False, Temporary:=True)

     ' CODE TYPE.
    Set MenuItem = .Controls.Add(Type:=msoControlPopup)
    With MenuItem
        .caption = "Buttons edit option"

        With .Controls.Add(Type:=msoControlButton)
            .caption = "copy button"
        End With

    End With

End With
End Sub

鼠标右键点击事件：

Public Sub btnFindSections_MouseDown(ByVal button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If button = 1 Then
    ElseIf button = 2 Then
        CreatePopUpMenu
    End If
End Sub

打开弹出窗口的代码：

Sub getCellReference()

Dim rng As Range
Dim FormatRuleInput As String

'Get A Cell Address From The User to Get Number Format From
  On Error Resume Next
    Set rng = Application.InputBox( _
      Title:="Copy Code to Cell", _
      Prompt:="Select the cell reference to copy to:", _
      Type:=8)
  On Error GoTo 0
End Sub

打开弹窗并获取单元格引用后，如何将按钮复制到新单元格？

Answer 1

试试这段代码为新创建的按钮创建事件。您将使用您的按钮名称调用Sub。在其复制期间或之后。您现在可以测试已复制按钮的代码。但是，如果您尝试逐行运行，代码将返回错误。立即运行 (F5)。并且注意在删除已经创建的事件之前不要运行两次。

Private Sub AddSheetEventButMouseDown(butName As String)
   'It needs a reference to 'Microsoft Visual Basic for Applications Extensibility x.x'
    Dim sh As Worksheet, wProj As VBIDE.VBProject, wCom As VBIDE.VBComponent
    Dim wMod As VBIDE.CodeModule

    Set sh = ActiveSheet 'the sheet where the event must be created!
                         'I used active sheet only for testing...
    With ActiveWorkbook
        Set wProj = .VBProject
        Set wCom = wProj.VBComponents(sh.codename)
        Set wMod = wCom.CodeModule
        With wMod
             .AddFromString "Private Sub " & butName & "_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)" & vbCrLf & _
                            "    If Button = 1 Then" & vbCrLf & _
                            "            MsgBox ""Left clicked""" & vbCrLf & _
                            "    ElseIf Button = 2 Then" & vbCrLf & _
                            "            CreatePopUpMenu" & vbCrLf & _
                            "    End If" & vbCrLf & _
                            "End Sub"
        End With
    End With
End Sub

它旨在准确地创建您需要的事件......

您还可以在同一步骤中创建 Click 事件，以包含它的方式构建字符串。

这段代码将（更简单）复制按钮并调用上面的Sub 来创建事件：

Private Sub testCopyButton(address As String)
 Dim sh As Worksheet, but As Shape, butName As String

 Set sh = ActiveSheet
  butName = "Just_copied"
  Set but = sh.Shapes("btnFindSections")
  but.Copy
  sh.Paste Destination:=sh.Range(address)
  On Error Resume Next
   sh.Shapes(sh.Shapes.count).Name = butName
   If Err.Number = 70 Then
        Err.Clear: On Error GoTo 0
        MsgBox "On the sheet " & sh.Name & ", a button named " & butName & " already exists..." & vbCrLf & _
               "You must delete it, or choose another button name and run the code again.", vbInformation, _
               "Wrong button name"
               sh.Shapes(sh.Shapes.count).Delete 'the last created button is deleted
               Exit Sub
   End If
  On Error GoTo 0

  AddSheetEventButMouseDown butName
End Sub

而测试Sub，调用上面的，将是：

Sub testCopyButton()
   testCopyButton "O15" 'use here your cell address where to be copied
                        'the sheet name can be also sent and the sub
                        'making the copying needs another parameter...
End Sub