问题
My first post here, but have been successfully sourcing solutions and ideas from this website for a while now. So thanks for the collection of solutions and ideas.
Basically, I have a spread sheet application requiring the first column, Column A, to be filled with "Active X" buttons in every cell, looping through for a given quantity. I have posted one such working solution below which makes use of "form type buttons" and a Modules. This exemplifies what I consider my most favored example with working buttons. Once operational the column of buttons will correspond to relative data on the same row, and when clicked will open corresponding folders, and userforms in later developments.
The second post uses the Range function, but obviously doesn't incorporate any buttons to interactive with. However, a mouse click over this Range will obviously activate any code from within the Worksheet_Selection Change procedure...Sorry just stating the obvious!
What I have been trying to achieve is a version of code employing "activeX" Command Buttons, but after having studied some great tutorials and poured over a range of programing concepts, I still fail miserably to employ OLEObjects.
How to add a button programmatically in VBA next to some sheet cell data?
Sheet 1 Procedure: Sub ColumnA_Buttons()
Dim buttons As Button
Dim rng As Range
Dim LineQty As Variant
Application.ScreenUpdating = False
ActiveSheet.buttons.Delete
LineQty = 5
For i = 1 To LineQty
Set rng = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
Set buttons = ActiveSheet.buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With buttons
.OnAction = "Buttons"
.Caption = "Line " & i
.Name = "Line " & i
End With
Next i
Application.ScreenUpdating = True
End Sub
Public Click_Button As Variant ' Make Variable Public for Userform1
'
Form Button Module:
Sub Line_Buttons()
Click_Button = Application.Caller
MsgBox Click_Button & " was Clicked"
UserForm1.Show 'Launch custom userform
End Sub
And the next option to be considered is a range detection
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' e.g., range(A1:E1) is clicked
If Not Application.Intersect(Target, Range("B2:B12")) Is Nothing Then
MsgBox "You clicked " & Target.Address
End If
End Sub
回答1:
Ok. I'm posting some code that I've been working on based on this post here: Multiple active X checkboxes... . It seems I've now come to the same stand still they did as descibed in their last post :
"Yes it is individual checkboxes. You can emulate control arrays in VBA so that each checkbox uses the same click event code, but that is probably overkill IMO. "
And if I read Jason's post above, this is what he's questioning regarding the event code.
Any assistance welcomed in completing this code, as I have Not yet seen a working example which interlocks it to a single event, as per the form button module above.
Sub Macro1()
Dim objCmdBtn As Object
Dim i As Integer
Dim Rnge As Range
Set ColumnRange = Range("A:A") ' Set width & height of column A
ColumnRange.ColumnWidth = 5: ColumnRange.RowHeight = 15.75
'Delete previous objCmdBtn
For Each objCmdBtn In ActiveSheet.OLEObjects
If TypeName(objCmdBtn.Object) = "CommandButton" Then objCmdBtn.Delete
Next objCmdBtn 'TypeName Function returns the data-type about a variable - TypeName(varname is objCmdBtn)
With ActiveSheet
For i = 1 To 25
Set Rnge = ActiveSheet.Range(Cells(i + 1, 1), Cells(i + 1, 1))
Set objCmdBtn = Sheets("Sheet1").OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Link:=False, _
DisplayAsIcon:=False, _
Left:=Rnge.Left, _
Top:=Rnge.Top, _
Width:=Rnge.Width, _
Height:=Rnge.Height)
With objCmdBtn
'set a String value as object's name
'.Name = "CommandButton1"
With .Object
.Caption = i
With .Font
.Name = "Arial"
.Bold = True
.Size = 7
.Italic = False
.Underline = False
End With
End With
End With
Next
End With
End Sub
回答2:
Here is an example of ActiveX buttons being created and coded to run. It may take some small tweaks, but will get the job done.
Sub CreateButton()
Dim Obj As Object
Dim Code As String
Dim cellLeft As Single
Dim cellTop As Single
Dim cellwidth As Single
Dim cellheight As Single
Dim LineQty as Integer
Sheets("Sheet1").Select
LineQty = 5
For i = 1 To LineQty
Set rng = ActiveSheet.Range(Cells(i, 1), Cells(i, 1))
cellLeft = rng.Left
cellTop = rng.Top
cellwidth = rng.Width
cellheight = rng.Height
'create button
Set Obj = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", Link:=False, DisplayAsIcon:=False, Left:=cellLeft, Top:=cellTop, Width:=cellWidth, Height:=cellHeight)
Obj.Name = "TestButton"
'button text
ActiveSheet.OLEObjects(1).Object.Caption = "Test Button"
'macro text to be added possibly by array?
Code = "Private Sub TestButton_Click()" & vbCrLf
Code = Code & "Call Tester" & vbCrLf
Code = Code & "End Sub"
'add macro at the end of the sheet module
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.Name).CodeModule
.insertlines
.CountOfLines + 1, Code
End With
Next i
End Sub
Sub Tester()
MsgBox "You have clicked on the test button"
End Sub
Note In order for this to not error on me, I had to go to the trust center and to trust center settings and macro settings and check the box "Trust Access to the VBA Project Object Model"
来源：https://stackoverflow.com/questions/38571963/how-to-add-activex-buttons-programmatically-in-vba-filling-all-rows-down-a-colu