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".
Related
I have excel Project that includes pictures. I have userform that has ImageBox. This form shows pictures dynamically according to row number with using selection change event.
This event triggered when cell selection change. But i want to triggered this event by clicking on shape. Is there any solution for that?
Please see image.
These are codes for cell selection change event.
Private Sub App_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Application.ScreenUpdating = False
Dim Pic As Shape
For Each Pic In ActiveSheet.Shapes
If Pic.TopLeftCell.Row = ActiveCell.Row Then
If Pic.Type = msoPicture Then
Pic.Select
Dim sheetName As String, MyPicture As String, strPicPath As String
sheetName = ActiveSheet.Name
MyPicture = Selection.Name
strPicPath = SavedPictureTo(MyPicture)' This function save image
Load ImageViever 'ImageViewer is UserForm name
With ImageViever
.Image1.Picture = LoadPicture(strPicPath)
.Show vbModeless
End With
Exit For
End If
End If
Next
Application.ScreenUpdating = True
End Sub
As written in the comments, you can assign a (parameterless) Sub to a shape that is executed when a shape is clicked.
In Excel, you can assign the macro by right-clicking on the shape and select "Assign macro".
With VBA, you write the name of the macro to the OnAction-property of the shape:
Dim sh As Shape
For Each sh In ActiveSheet.Shapes ' <-- Select the sheet(s) you need
sh.OnAction = "HelloWorld" ' <-- Change this to the name of your event procedure
Next
If you want to know which shape was clicked, you can use the Application.Caller property. When the macro was called by clicking on a shape, it contains the name of that shape.
Sub helloWorld()
Dim sh As Shape
On Error Resume Next
Set sh = ActiveSheet.Shapes(Application.Caller)
On Error GoTo 0
If sh Is Nothing Then
MsgBox "I was not called by clicking on a shape"
Else
MsgBox "Someone clicked on " & sh.Name
End If
End Sub
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 have written VBA with 3 modules that work perfectly and the userform works as well when I run it from Developer - VBA window. I need to add the userform to my add-in to activate when I need it. I added the 4th module to install the macro
Sub Add_MainframeScrape_Menu()
Dim cbWSMenuBar As CommandBar
Dim muInbound As CommandBarControl
Dim iHelpIndex As Integer
Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
iHelpIndex = cbWSMenuBar.Controls("Help").Index
Set muInbound = cbWSMenuBar.Controls.Add(Type:=msoControlPopup, Before:=iHelpIndex)
With muInbound
.Caption = "EDIMACROS"
With .Controls.Add '(Type:=msoControlPopup)
.Caption = "EDIMACROS"
.OnAction = "EDI_REPORTS"
End With
End With
End Sub
And I added the below code to the form itself to start when I click on add-ins
Public Sub EDI_MACROS_Initialize()
Me.Show
End Sub
But it's not working please help.
The OnAction should be the name of a Sub (in a regular module) which displays the form, not the name of the form
Sub Add_MainframeScrape_Menu()
Dim cbWSMenuBar As CommandBar
Dim muInbound As CommandBarControl
Dim iHelpIndex As Integer
Set cbWSMenuBar = Application.CommandBars("Worksheet Menu Bar")
iHelpIndex = cbWSMenuBar.Controls("Help").Index
Set muInbound = cbWSMenuBar.Controls.Add(Type:=msoControlPopup, _
Before:=iHelpIndex)
With muInbound
.Caption = "EDIMACROS"
With .Controls.Add '(Type:=msoControlPopup)
.Caption = "EDIMACROS"
.OnAction = "Show_EDI_MACROS"
End With
End With
End Sub
Public Sub Show_EDI_MACROS()
EDI_REPORTS.Show 'assumes your form is named "EDI_REPORTS"
End Sub
Hello so what i want to do is make this code work for all Check Box's 1-50 I want the code to only effect the box that is clicked.
Private Sub CheckBox1_Click()
If MsgBox("Do you want to lock this box?", vbYesNo, "Warning") = vbYes Then
ActiveSheet.CheckBox2.Enabled = False
Else
End If
End Sub
I see several options (none of which are pretty since this is VBA).
Option 1: generate the code for all of your check boxes. This is probably the most maintainable. You would first choose reasonable names for all your check boxes (you can assign them by selecting them in Excel and renaming in the top left corner, or run code which will do this for you if you already have a lot of check boxes. This may be useful).
You can then generate the code and have each one of your subprocedues as follows:
'example code for one checkbox
Private Sub chkBox_1_Click()
Call lockMeUp(Sheet1.chkBox_1.Object)
End Sub
After you're done with all your code for each checkbox, you could have your lockMeUp subprocedure as follows:
Sub lockMeUp(chkBox as Object)
If MsgBox("Do you want to lock this box?", vbYesNo, "Warning") = vbYes Then
chkBox.Enabled = False
End If
End Sub
Option 2: Keep track of all your checked/unchecked statuses through either an Array or a "Settings" hidden sheet, and watch out for that triggered event. You could fire off based off of a sheet's Changed event, and match the row number to your CheckBox number so that you can go off of the Target's row number.
Other options I can think of become more convoluted... I'd be interested to see what other suggestions people have. Thanks!
EDIT You can use some code to refer to a single function as in my example, in conjunction with brettdj's example to get your optimal solution. Bam!
The easy way is to write a class module that will apply one code routine to a collection of Checkboxes
Assuming yu want to run this on all ActiveX checkboxes on the ActiveSheet, then borrowing heavily from Bob Phillip's code from VBAX
Insert a Class Module named clsActiveXEvents
Option Explicit
Public WithEvents mCheckboxes As MSForms.CheckBox
Private Sub mCheckboxes_Click()
mCheckboxes.Enabled = (MsgBox("Do you want to lock this box?", vbYesNo, "Warning") = vbNo)
End Sub
In a normal module use this code
Dim mcolEvents As Collection
Sub Test()
Dim cCBEvents As clsActiveXEvents
Dim shp As Shape
Set mcolEvents = New Collection
For Each shp In ActiveSheet.Shapes
If shp.Type = msoOLEControlObject Then
If TypeName(shp.OLEFormat.Object.Object) = "CheckBox" Then
Set cCBEvents = New clsActiveXEvents
Set cCBEvents.mCheckboxes = shp.OLEFormat.Object.Object
mcolEvents.Add cCBEvents
End If
End If
Next
End Sub
In case you do not know, all Form Controls are treated as Shapes in a Worksheet.
I have a solution that you need to create a new Module, copy-paste in code below and then from Immediate window to the same module. With some assumptions:
All Check Box Objects are named "Check Box #" where # is a number
No macro named ResetCheckBoxes() in any other modules of the workbook
No macro named CheckBox#_Click() in any other modules of the workbook
Run this ResetCheckBoxes once to enable check boxes and Assign a macro to it for you, with relevant generated codes in the immediate window (you might want to put a pause in the loop every 25 check boxes as line buffer in it are limited).
Sub ResetCheckBoxes()
Dim oWS As Worksheet, oSh As Shape, sTmp As String
Set oWS = ThisWorkbook.ActiveSheet
For Each oSh In oWS.Shapes
With oSh
If .Type = msoFormControl Then
If InStr(1, .Name, "Check Box", vbTextCompare) = 1 Then
.ControlFormat.Enabled = True
sTmp = "CheckBox" & Replace(oSh.Name, "Check Box ", "") & "_Click"
.OnAction = sTmp
Debug.Print "Sub " & sTmp & "()"
Debug.Print vbTab & "ActiveSheet.Shapes(""" & .Name & """).ControlFormat.Enabled = False"
Debug.Print "End Sub" & vbCrLf
End If
End If
End With
Next
End Sub
Example Immediate window output (2 test check boxes):
Happy New Year mate!
To build on the solution offered by #brettdj, since he is specifying ActiveX Controls, I would suggest the following in the Standard Module:
Dim mcolEvents As Collection
Sub Test()
Dim cCBEvents As clsActiveXEvents
Dim o As OLEObject
Set mcolEvents = New Collection
For Each o In ActiveSheet.OLEObjects
If TypeName(o.Object) = "CheckBox" Then
Set cCBEvents = New clsActiveXEvents
Set cCBEvents.mCheckboxes = o.Object
mcolEvents.Add cCBEvents, o.Name
End If
Next
End Sub
The differences are:
I use the OLEObjects Collection because it is more direct and doesn't waste time on non-OLE shapes.
I use TypeName instead of (the mysterious) TypeOf operator because (apparently) the later does not discriminate between OptionButton and CheckBox.
I register the Object Name as Key in the Collection to allow for efficient indexing if required.
EDIT:
I should have followed the link provided by #brettdj before posting. My solution is using the same principles as are outlined there. Hopefully, its convenient to have it documented here as well?
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.