Printable View
I need to create two buttons (at the same time) and add code to them. Not the same code for both. Each one must call a sub. I know how to add a code to the first button or add code to subsequente buttons, but only if i run the code twice and i need them to be added both the first time i run the code. Tried for ... next already but didnt succeed.
Any suggestions?
Hi Carlos,
Nate Oliver helped me with this one a while ago. You should be able to modify the button names and procedure names to suit. Remember to set a reference to the VBA Extensibility Library and also to ensure that you've trusted access to the VB Project. (Tools|Options|Security|Macro Security|Trusted Publishers... or something like that!)
Code:Sub Add_Command_Buttons()
'Macro purpose: To create 2 pre-formatted command buttons on the worksheet
'SECTION 1
'Declare required variables and working environment
Dim cl As Range, ctrl As OLEObject, i, LineNum As Integer
Dim TargetSheet As Worksheet, TargetBook As Workbook
Application.ScreenUpdating = False
Set TargetSheet = ActiveSheet
Set TargetBook = ActiveWorkbook
'SECTION 2
'Add preformated buttons to worksheet
For Each cl In [A1,I1] 'update this range to place buttons
i = i + 1
Set ctrl = TargetSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Left:=cl.Left + 1, Top:=cl.Top + 1, Width:=Choose(i, 48, 72.75), Height:=56.25)
With ctrl
.Name = Choose(i, "RollForward", "PrintAll_Standard")
.Placement = xlMove
.PrintObject = False
With .Object
.BackColor = Choose(i, &HC0FFC0, &HFFC0C0)
.Caption = Choose(i, "Roll Forward To New Month", _
"Print Working Paper & AJE")
.Enabled = True
.Font.Name = "Times New Roman"
.Font.Size = 10
.Font.Bold = True
.TakeFocusOnClick = False
.WordWrap = True
End With
End With
Next
'TargetBook.VBProject.VBComponents.Add(1) 'to add a new Module1
With TargetBook.VBProject.VBComponents(TargetSheet.CodeName).CodeModule
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Private Sub RollForward_Click()" & vbLf & _
" Msgbox ""Here is the new procedure"" " & vbLf & _
"End Sub"
End With
With TargetBook.VBProject.VBComponents(TargetSheet.CodeName).CodeModule
LineNum = .CountOfLines + 1
.InsertLines LineNum, _
"Private Sub PrintAll_Standard_Click()" & vbLf & _
" Msgbox ""Here is the new procedure"" " & vbLf & _
"End Sub"
End With
Application.ScreenUpdating = True
End Sub
Hi Ken,
gee this is great! Exactly what I needed. Of course now I will try to alter it a bit as now I want to add 3 buttons, but reading the code believe its gonna be easy.
Thank you very much!
Hi again Ken,
worked just fine, this is my final code:
Code:Sub Add_Command_Buttons()
Dim cl As Range, myCmdObj As OLEObject, i, LineNum As Integer
Dim TargetSheet As Worksheet, TargetBook As Workbook
Application.ScreenUpdating = False
Set TargetSheet = ActiveSheet
Set TargetBook = ActiveWorkbook
For Each cl In [A14,A20,A25]
i = i + 1
Set myCmdObj = TargetSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Left:=cl.Left + 1, Top:=cl.Top + 1, Width:=202.5, Height:=32.25)
With myCmdObj
.Name = Choose(i, "cmdReexibirNC", "cmdSubtotalNC", "cmdResumo")
.Placement = xlMove
.PrintObject = False
With .Object
.Caption = Choose(i, "Reexibe todas colunas e remove subtotais", _
"Gera subtotais e oculta colunas", _
"Analisa outras opera??es")
.Enabled = True
.Font.Size = 10
.Font.Bold = True
.TakeFocusOnClick = False
.WordWrap = True
End With
End With
Next
Set myCmdObj = Nothing
With TargetBook.VBProject.VBComponents(TargetSheet.CodeName).CodeModule
LineNum = .CountOfLines + 1
.InsertLines LineNum, "Private Sub cmdReexibirNC_Click()"
.InsertLines LineNum + 1, vbNewLine
.InsertLines LineNum + 2, vbTab & "Reexibe_NC"
.InsertLines LineNum + 3, vbNewLine
.InsertLines LineNum + 4, "End Sub"
End With
With TargetBook.VBProject.VBComponents(TargetSheet.CodeName).CodeModule
LineNum = .CountOfLines + 1
.InsertLines LineNum, "Private Sub cmdSubtotalNC_Click()"
.InsertLines LineNum + 1, vbNewLine
.InsertLines LineNum + 2, vbTab & "Subtotal_NC"
.InsertLines LineNum + 3, vbNewLine
.InsertLines LineNum + 4, "End Sub"
End With
With TargetBook.VBProject.VBComponents(TargetSheet.CodeName).CodeModule
LineNum = .CountOfLines + 1
.InsertLines LineNum, "Private Sub cmdResumo_Click()"
.InsertLines LineNum + 1, vbNewLine
.InsertLines LineNum + 2, vbTab & "Analisa"
.InsertLines LineNum + 3, vbNewLine
.InsertLines LineNum + 4, "End Sub"
End With
Application.ScreenUpdating = True
End Sub
Glad it worked!
Please ignore this thread, I have posted it here http://www.vbaexpress.com/forum/show...4586#post14586, answer there please.: pray2:
Hi,
gee here I am again. Another problem. I need to put the buttons side by side and bellow a row I dont know which is.
I tried this:
Code:For Each cl In [replace(Range("B65536").End(xlUp).Address,"$",""), replace(Range("D65536").End(xlUp).Address,"$",""), replace(Range("H65536").End(xlUp).Address,"$","")]
Didnt work. Any suggestions?
This one is already solved, just read the previous, please.
This is the one I wanna change and t has another error. Two buttons are being positioned one above another. The ones from column "B".
Code:For Each cl In [B5664,B5668,H5664] 'update this range to place buttons
i = i + 1
Set myCmdObj = TargetSheet.OLEObjects.Add(ClassType:="Forms.CommandButton.1", _
Left:=cl.Left + 1, Top:=cl.Top + 1, Width:=202.5, Height:=32.25)
Any suggestions about this thread and the one before it?