I have some code that creates and deletes a cell menu control.
This control should only be displayed on a certain worksheet, so when the user switches sheet it gets deleted.
The problem I'm having is that part of the code that is called from the control changes the selected sheet and this causes a Method 'Delete' of object '_CommandBarButton' failed error.
I'm guessing this is because the button is still active while the code is executing, so it can't be deleted.
Does anyone know of any work around for this?
To use the code create a workbook with two worksheets with codenames Sheet1 and Sheet2.
I'm using Excel for Office 365 ProPlus, but I don't think that's part of the issue here.
The code I have:
ThisWorkbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
DeleteFromCellMenu
End Sub
Private Sub Workbook_Open()
If ActiveSheet.CodeName = "Sheet1" Then AddCellToMenu
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.CodeName = "Sheet1" Then
AddCellToMenu
End If
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
DeleteFromCellMenu
End Sub
Normal Module
The error occurs near the end of the last procedure (ctrl.Delete).
'''''''''''''''''
'This is the procedure called by the control button.
'''''''''''''''''
Sub Test()
Sheet2.Select
End Sub
Sub AddCellToMenu()
Dim Menu(0 To 1) As Variant
Dim vItm As Variant
Dim ContextMenu As CommandBar
Menu(0) = "Cell"
Menu(1) = "List Range Popup"
'Delete the controls first to avoid duplicates
Call DeleteFromCellMenu
For Each vItm In Menu
Set ContextMenu = Application.CommandBars(vItm)
'Add the control button.
With ContextMenu.Controls.Add(Type:=msoControlButton, Before:=1)
.Caption = "Create Pre-Alert"
.Tag = "Customs_Tag"
.FaceId = 1392
.OnAction = "'" & ThisWorkbook.Name & "'!" & "Test"
End With
ContextMenu.Controls(2).BeginGroup = True
Next vItm
End Sub
Sub DeleteFromCellMenu()
Dim Menu(0 To 1) As Variant
Dim vItm As Variant
Dim ContextMenu As CommandBar
Dim ctrl As CommandBarControl
Menu(0) = "Cell"
Menu(1) = "List Range Popup"
For Each vItm In Menu
'Set ContextMenu to the Cell menu
Set ContextMenu = Application.CommandBars(vItm)
'Delete custom controls with the Tag : Customs_Tag
For Each ctrl In ContextMenu.Controls
If ctrl.Tag = "Customs_Tag" Then
ctrl.Delete '<<<ERROR OCCURS HERE.
End If
Next ctrl
Next vItm
End Sub
I am using Excel 2003 with VBA, I am dynamically creating check box controls on a sheet and want to link the VBA controls to a class so that when a user clicks on a checkbox an event is fired so I can do something.
From what I've read it would seem that creating a user class is the solution, but having tried this I can't get it to work.
My user class looks like this:
Option Explicit
Public WithEvents cbBox As MSForms.checkbox
Private Sub cbBox_Change()
MsgBox "_CHANGE"
End Sub
Private Sub cbBox_Click()
MsgBox "_CLICK"
End Sub
My code to create the checkboxes:
For Each varExisting In objColumns
'Insert the field name
objColumnHeadings.Cells(lngRow, 1).Value = varExisting
'Insert a checkbox to allow selection of the column
Set objCell = objColumnHeadings.Cells(lngRow, 2)
Dim objCBclass As clsCheckbox
Set objCBclass = New clsCheckbox
Set objCBclass.cbBox = ActiveSheet.OLEObjects.Add( _
ClassType:="Forms.CheckBox.1" _
, Left:=300 _
, Top:=(objCell.Top + 2) _
, Height:=10 _
, Width:=9.6).Object
objCBclass.cbBox.Name = "chkbx" & lngRow
objCBclass.cbBox.Caption = ""
objCBclass.cbBox.BackColor = &H808080
objCBclass.cbBox.BackStyle = 0
objCBclass.cbBox.ForeColor = &H808080
objCheckboxes.Add objCBclass
lngRow = lngRow + 1
Next
The checkboxes are visible in the sheet, but when I click on them, no message box is displayed so the link to the class doesn't seem to be working.
Why?
Edit...If after adding the checkboxes I go into the VB IDE and select one of the created checkboxes from the list of controls, then select Click from the Procedure drop down list, it will insert the code for a call back which if I add a message box to this, works when I click on the same checkbox...so how can I achieve this in code? I've tried recording a macro to do this, nothing was recorded.
Edit by S.Platten, jump to the bottom for how this helped me fix the problem...
Due to some weird reason, VBA doesn't hook up the events for Sheet's ActiveX control in the same execution cycle in which they were added. So, we need to come out of the cycle which added the controls and then invoke the event adding proc in next cycle. Application.OnTime helps here.
Its seems a bit of overkill but it works :)
Option Explicit
Dim collChk As Collection
Dim timerTime
Sub master()
'/ Add the CheckBoxes First
Call addControls
'<< Due to some weird reason, VBA doesn't hook up the events for Sheet's ActiveX control in the same
'execution cycle in which they were added. So, we need to come out of the cycle which added the controls
'and then invoke the event adding proc in next cycle. >>
'/ Start Timer. Timer will call the sub to add the events
Call StartTimer
End Sub
Sub addControls()
Dim ctrlChkBox As MSForms.CheckBox
Dim objCell As Range
Dim i As Long
'Intialize the collection to hold the classes
Set collChk = New Collection
'/ Here Controls are added. No Events, yet.
For i = 1 To 10
Set objCell = Sheet1.Cells(i, 1)
Set ctrlChkBox = Sheet1.OLEObjects.Add( _
ClassType:="Forms.CheckBox.1" _
, Left:=1 _
, Top:=(objCell.Top + 2) _
, Height:=objCell.Height _
, Width:=100).Object
ctrlChkBox.Name = "chkbx" & objCell.Row
Next
End Sub
Sub addEvents()
Dim ctrlChkBox As MSForms.CheckBox
Dim objCBclass As clsCheckBox
Dim x As Object
'Intialize the collection to hold the classes
Set collChk = New Collection
'/ Here we assign the event handler
For Each x In Sheet1.OLEObjects
If x.OLEType = 2 Then
Set ctrlChkBox = x.Object
Set objCBclass = New clsCheckBox
Set objCBclass.cbBox = ctrlChkBox
collChk.Add objCBclass
Debug.Print x.Name
End If
Next
'/ Kill the timer
Call StopTimer
End Sub
Sub StartTimer()
timerTime = Now + TimeSerial(0, 0, 1)
Application.OnTime EarliestTime:=timerTime, Procedure:="addEvents", _
Schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=timerTime, Procedure:="addEvents", _
Schedule:=False
End Sub
Class Module: clsCheckBox
Option Explicit
Public WithEvents cbBox As MSForms.CheckBox
Private Sub cbBox_Change()
MsgBox "_CHANGE"
End Sub
Private Sub cbBox_Click()
MsgBox "_CLICK"
End Sub
Edit continued...
The class (clsCheckbox):
Option Explicit
Public WithEvents cbBox As MSForms.checkbox
Private Sub cbBox_Click()
MsgBox "_CLICK"
End Sub
Module1
Public objCheckboxes As Collection
Public tmrTimer
Public Sub addEvents()
Dim objCheckbox As clsCheckbox
Dim objMSCheckbox As Object
Dim objControl As Object
Set objCheckboxes = New Collection
For Each objControl In Sheet1.OLEObjects
If objControl.OLEType = 2 _
And objControl.progID = "Forms.CheckBox.1" Then
Set objMSCheckbox = objControl.Object
Set objCheckbox = New clsCheckbox
Set objCheckbox.cbBox = objMSCheckbox
objCheckboxes.Add objCheckbox
End If
Next
Call stopTimer
End Sub
Public Sub startTimer()
tmrTimer = Now + TimeSerial(0, 0, 1)
Application.OnTime EarliestTime:=tmrTimer _
, Procedure:="addEvents" _
, Schedule:=True
End Sub
Public Sub stopTimer()
On Error Resume Next
Application.OnTime EarliestTime:=tmrTimer _
, Procedure:="addEvents" _
, Schedule:=False
End Sub
The code in the sheet that adds the controls:
Dim objControl As MSForms.checkbox
For Each varExisting In objColumns
'Insert the field name
objColumnHeadings.Cells(lngRow, 1).Value = varExisting
'Insert a checkbox to allow selection of the column
Set objCell = objColumnHeadings.Cells(lngRow, 2)
Set objControl = ActiveSheet.OLEObjects.Add( _
ClassType:="Forms.CheckBox.1" _
, Left:=300 _
, Top:=(objCell.Top + 2) _
, Height:=10 _
, Width:=9.6).Object
objControl.Name = "chkbx" & lngRow
objControl.Caption = ""
objControl.BackColor = &H808080
objControl.BackStyle = 0
objControl.ForeColor = &H808080
lngRow = lngRow + 1
Next
This isn't the entire project, but enough to demonstrate the workings.
You are currently using ActiveX controls. Yet, ActiveX controls are bound to specific naming conventions. For example: if you insert an ActiveX button onto a sheet and name it btnMyButton then the sub must be named btnMyButton_Click. The same applies to checkboxes. If you insert a new checkbox with the name CheckBox2 then the sub's name must be CheckBox2_Click. In short, there cannot be a sub with the name cbBox_Change associated to any ActiveX checkbox.
So, what you really need (with ActiveX controls) is a way to change the VBA code on a sheet. But thus far I have never come across any such code (VBA code to change VBA code on a sheet).
A much easier route would be if you'd be willing to use form controls instead.
The following sub will create a (form control) checkbox and assign the macro tmpSO to it. The sub tmpSO (unlike subs for ActiveX controls) does not need to reside on the sheet but can be in any module.
Sub Insert_CheckBox()
Dim chk As CheckBox
Set chk = ActiveSheet.CheckBoxes.Add(390.75, 216, 72, 72)
chk.OnAction = "tmpSO"
End Sub
Since a from control is calling the sub tmpSO you can use Application.Caller in that sub and thereby know which checkbox has been calling this sub.
Sub tmpSO()
Debug.Print Application.Caller
End Sub
This will return the name of the CheckBox. So, you can use this one sub for all of your checkboxes any dynamically handle them based on their names (possibly using a Case Select).
Here is another example for tmpSO:
Sub tmpSO()
With ThisWorkbook.Worksheets(1).CheckBoxes(Application.Caller)
MsgBox "The checkbox " & Application.Caller & Chr(10) & _
"is currently " & IIf(.Value = 1, "", "not") & " checked."
End With
End Sub
I am trying to create pop-up menu, that will give option to copy-paste a shape object out from shape group named "Element" (Oval + Text Box).
But it seemed that Select & Paste methods did not work.
Public Element_Menu As CommandBar
Function CreateSubMenu() As CommandBar
Const pop_up_name = "pop-up menu"
Dim the_command_bar As CommandBar
Dim the_command_bar_control As CommandBarControl
For Each menu_item In CommandBars
If menu_item.Name = pop_up_name Then
CommandBars(pop_up_name).Delete
End If
Next
Set the_command_bar = CommandBars.Add(Name:=pop_up_name, Position:=msoBarPopup, MenuBar:=False, Temporary:=False)
Set the_command_bar_control = the_command_bar.Controls.Add
the_command_bar_control.Caption = "Add &Element"
the_command_bar_control.OnAction = "AddElement"
Set CreateSubMenu = the_command_bar
End Function
Sub ElementClick()
Set Element_Menu = CreateSubMenu
Element_Menu.ShowPopup
End Sub
Sub AddElement()
ActiveSheet.Shapes("Element").Select 'Selecting template object to replicate
ActiveSheet.Paste 'Inserting copy out from the clipboard
End Sub
Is the shape that is added correctly named "Element" (as per the line that does not work?) It seems that it is called "Test Element".
I'm using the following script to produce buttons in excel, the range is just where I'd like it to be placed.
Sub CreateAddButton(rng As Range)
Dim btn As Button
With Worksheets("User")
Set btn = .Buttons.Add(rng.Left, rng.Top, rng.width, rng.Height)
With btn
.name = "Add"
.Caption = "Add Column"
.OnAction = "CreateVariable"
End With
End With
End Sub
Only problem is, I'd like a method which can delete all the buttons produced by this method? I want to steer away from global variables if possible. Any help would be gratefully received.
James
I'd suggest Tim's method using a specific name - which does't need a global variable. For example you could add a
"_||ForDeletion" suffix to each button name and then look for it on a delete routine
.Name = "Add_||ForDeletion"
A Forms button does provide another alternative though (no pun intended), you can store a text sting in the AlternativeText under "Properties" then "Web" and use this as an identifier for a delete routine.
The delete routine at bottom works backwards to avoid errors when looping through a range
Sub TesMe()
Call CreateAddButton([a2])
End Sub
Sub CreateAddButton(rng As Range)
Dim btn As Button
With Worksheets("User")
Set btn = .Buttons.Add(rng.Left, rng.Top, rng.Width, rng.Height)
With btn
.Name = "Add"
.Caption = "Add Column"
.OnAction = "CreateVariable"
.ShapeRange.AlternativeText = "MyCollection"
End With
End With
End Sub
Sub GetMyButtons()
Dim btns As Object
Dim lngRow As Long
Set btns = Sheets("User").Buttons
For lngRow = btns.Count To 1 Step -1
If btns(lngRow).ShapeRange.AlternativeText = "MyCollection" Then
MsgBox "Found one", vbCritical
btns(lngRow).Delete
End If
Next
End Sub
Buttons in VBA are in the Shapes collection. You can use:
Sub deleteButtons()
Dim btn As Shape
For Each btn In ActiveSheet.Shapes
If btn.AutoShapeType = msoShapeStyleMixed Then btn.Delete
Next
End Sub
msoShapeStyleMixed seems to be the type for all Form and ActiveX controls.
i have a macro (Makro1) that is assigned to a button in a custom toolbar (Custom1) with caption "Schutzstatus". i want the toolbar only to be loaded with this very xls-file.
can someone help me out with the code?
i managed to customize the tooltip:
Application.CommandBars("Custom1").Controls(1).TooltipText = "Abfrage des Schutzstatus der Arten im Zwischenspeicher"
but i fail in creating the whole thing by vba..
thanks in advance,
kay
You don't actually need to (re)create the whole toolbar on loading your XLS, but you need to display/hide it during certain navigations
1 create the toolbar
2 attach it to your XLS (view / toolbars / customize .... / attach)
3 create event procedures to show/hide your toolbar; unless you want to have a specific behaviour for different sheets, the following should be enough to care for all navigation:
Private Sub Workbook_Activate()
' show toolbar
Application.CommandBars("CoolBar").Visible = True
Application.CommandBars("CoolBar").Controls(1).TooltipText = "C'mon squeeze me"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' drop toolbar
Application.CommandBars("CoolBar").Delete
End Sub
Private Sub Workbook_Deactivate()
' see if we have a toolbar (it might have been already deleted by "Workbook_BeforeClose"
' if yes - hide it
Dim Idx As Integer
For Idx = 1 To Application.CommandBars.Count
If Application.CommandBars(Idx).Name = "CoolBar" Then
Application.CommandBars("CoolBar").Visible = False
End If
Next Idx
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' display toolbar
Application.CommandBars("CoolBar").Visible = True
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Application.CommandBars("CoolBar").Visible = False
End Sub
Place all in the "ThisWorkbook" object - so they fire on all sheets.
4 After saving the toolbar with the XLS and testing, close the XLS - the toolbar will be still present in your application object - and delete the toolbar from there. Don't panic, it's coming back when you re-open your XLS file.
Hope this helps
Tschüss MikeD
Actually the answer was close but didn't work for me. That .Delete does delete the command bar completely as confirmed by Kay in his last comment. You basically had to recreate but bar and button again when the workbook is opened. Below is the improved code:
Private Sub Workbook_Activate()
' show toolbar
Dim SortBar As CommandBar
Dim BarControl As CommandBarControl
Set SortBar = FindCommandBar("SortBar")
If SortBar Is Nothing Then
Set SortBar = Application.CommandBars.Add("SortBar")
Set BarControl = SortBar.Controls.Add
BarControl.OnAction = "Your_Macro_Name"
BarControl.Caption = "Text for your button"
BarControl.Style = msoButtonCaption
End If
SortBar.Visible = True
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
' drop toolbar
Application.CommandBars("SortBar").Delete
End Sub
Private Sub Workbook_Deactivate()
' see if we have a toolbar (it might have been already deleted by "Workbook_BeforeClose"
' if yes - hide it
Dim SortBar As CommandBar
Set SortBar = FindCommandBar("SortBar")
If Not SortBar Is Nothing Then
SortBar.Visible = False
End If
End Sub
Private Function FindCommandBar(Name As String) As CommandBar
Dim Idx As Integer
For Idx = 1 To Application.CommandBars.Count
Set FindCommandBar = Application.CommandBars(Idx)
If FindCommandBar.Name = Name Then
Exit Function
End If
Next Idx
Set FindCommandBar = Nothing
End Function
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
' display toolbar
Application.CommandBars("SortBar").Visible = True
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Application.CommandBars("SortBar").Visible = False
End Sub