复制并粘贴activeX按钮 [英] Copy and paste the activeX button

问题描述

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

I have custom right click menu from which when I click sub menu item I want to open a pop window to allow user to enter destination or reference cell to copy and paste the parent button (activeX)

用户点击了复制到":

弹出式窗口:允许用户选择图纸上的任何单元格或手动输入目标单元格引用.

Pop up opened: Allow user to select any cell on sheet or manually enter destination cell ref.

当我单击确定"按钮时，该按钮的副本应位于 E14

When I click on "Ok" button, a copy of button should be in 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

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

After opening the pop up and getting the cell reference, how do I copy the button to new cell?

推荐答案

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

Try this piece of code to create the event for the newly created button. You will call the Sub using your button name. During its copying or after. You can test now the code for the already copies button. But it the code will return an error if you try running it line by line. Run it at once (F5). And be careful to not run it twice before deleting the already created event.

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

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

It is designed to exactly create the event you need...

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

You can also create the Click event in the same step, building the string in a way to also contain it.

这段代码(简单)将复制按钮并调用上面的 Sub 创建事件:

This piece of code will (simpler) copy the button and call the above Sub to create the event:

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 将是:

And the test Sub, calling the above one, will be:

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

这篇关于复制并粘贴activeX按钮的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！