Excel VBA для добавления макроса в CommandButton элемента управления ActiveX на листе 1 активной рабочей книги

Question

У меня есть макрос, который создает элемент управления ControlX ActiveX как объект.

Dim buttonControl As MSForms.CommandButton

    Set buttonControl = _
        ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
            Link:=False, _
            DisplayAsIcon:=False, _
            Left:=1464, Top:=310, Width:=107.25, Height:=30).Object

    With buttonControl
        .Caption = "OPEN FOLDER"
        .Name = "cmd_OPEN_FOLDER"
        .BackColor = "12713921"

    End With

И у меня есть макрос, который открывает назначенную папку.

Private Sub cmd_OPEN_FOLDER_Click()

    Dim FolderPath As String
    Dim FinalFolder As String

    FolderPath = "C:\ExampleFolder1\ExampleFolder2\"

    FinalFolder = ActiveSheet.Range("N1").Value & "\"

        Call Shell("explorer.exe """ & FolderPath & FinalFolder & "", vbNormalFocus)

End Sub

Как можно, чтобы макрос, который создает CommandButton, также создавал макрос и связывал его с объявленной переменной CommandButton (buttonControl)?

Я хотел бы, чтобы он был в MicrosoftМодуль Excel Object;Sheet1 (Лист1), чтобы все было организовано.

Answer 1

Чтобы назначить существующий макрос фигуре, выберите его и измените свойство OnAction:

Selection.OnAction = "YourMacroName"

Чтобы создать новый модуль с VBA, адаптируйте следующую технику VBIDE для своих нужд:

Private Function addModule() As String
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents.Add(vbext_ct_StdModule)
Set CodeMod = VBComp.CodeModule
With CodeMod
    .DeleteLines 1, .CountOfLines
    .InsertLines 1, "Sub ShowHide()"
    .InsertLines 2, "     If ActiveSheet.Shapes.Range(""btnHideShow"").TextFrame2.TextRange.Characters.Text = ""Show Orders with Inventory over Safety Stock"" Then"
    .InsertLines 3, "          ActiveSheet.AutoFilterMode = False"
    .InsertLines 4, "          ActiveSheet.Shapes.Range(""btnHideShow"").TextFrame2.TextRange.Characters.Text = ""Hide Orders with Inventory over Safety Stock"""
    .InsertLines 5, "     Else"
    .InsertLines 6, "          range(""M1"").select"
    .InsertLines 7, "          Selection.AutoFilter"
    .InsertLines 8, "          ActiveSheet.Range(""$A$1:$Q$1000000"").AutoFilter Field:=13, Criteria1:=""<=12"", Operator:=xlAnd"
    .InsertLines 9, "          ActiveSheet.Range(""$A$1:$Q$100000"").AutoFilter Field:=17, Criteria1:=""="""
    .InsertLines 10, "          ActiveSheet.Shapes.Range(""btnHideShow"").TextFrame2.TextRange.Characters.Text = ""Show Orders with Inventory over Safety Stock"""
    .InsertLines 11, "     End If"
    .InsertLines 12, "End Sub"
End With
addModule = VBComp.Name
End Function

Следующее создаст подпрограммы, которые вы хотите в объекте Sheet1:

Sub GenerateSheet1Macros()
    'assign a commandbutton, shape, event, etc to this subroutine
    addModule
End Sub

Private Function addModule() As String
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Set VBProj = ActiveWorkbook.VBProject
Set VBComp = VBProj.VBComponents("Sheet1")
Set CodeMod = VBComp.CodeModule
With CodeMod
    .DeleteLines 1, .CountOfLines
    .InsertLines 1, "Option Explicit" & vbCrLf & _
    "Sub CreateButton()" & vbCrLf & _
    "    Dim buttonControl As MSForms.CommandButton" & vbCrLf & _
    "    Set buttonControl = _" & vbCrLf & _
    "    ActiveSheet.OLEObjects.Add(ClassType:=""Forms.CommandButton.1"", _" & vbCrLf & _
    "        Link:=False, _" & vbCrLf & _
    "        DisplayAsIcon:=False, _" & vbCrLf & _
    "        Left:=100, Top:=100, Width:=100, Height:=100).Object" & vbCrLf & _
    "    With buttonControl" & vbCrLf & _
    "        .Caption = ""OPEN FOLDER""" & vbCrLf & _
    "        .Name = ""cmd_OPEN_FOLDER""" & vbCrLf & _
    "        .BackColor = ""12713921""" & vbCrLf & _
    "    End With" & vbCrLf & _
    "End Sub" & vbCrLf & _
    "Private Sub cmd_OPEN_FOLDER_Click()" & vbCrLf & _
    "    Dim FolderPath As String" & vbCrLf & _
    "    Dim FinalFolder As String" & vbCrLf & _
    "    FolderPath = ""C:\ExampleFolder1\ExampleFolder2\""" & vbCrLf & _
    "    FinalFolder = ActiveSheet.Range(""N1"").Value & "" \ """ & vbCrLf & _
    "    Call Shell(""explorer.exe """""" & FolderPath & FinalFolder & """", vbNormalFocus)" & vbCrLf & _
    "End Sub"
End With
End Function