I'm currently trying to auto name the objects from a referenced list rather than just have the object text stated in the script.
How do I get the script to reference a separate worksheet called Process Steps where the text value is in cell C7 instead of entering the statement in the script as Step 1
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 50).Select
Selection.Formula = ""
Selection.ShapeRange.ShapeStyle = msoShapeStylePreset40
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Step1"
Peter has already mentioned how to pick up a value from another cell. Taking this a bit ahead.
Please avoid the use of .Select/.Activate INTERESTING READ
Is this what you are trying?
Sub Sample()
Dim shp As Shape
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 50)
With shp.OLEFormat.Object
.Formula = ""
.ShapeRange.ShapeStyle = msoShapeStylePreset40
.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
ThisWorkbook.Sheets("Process Steps").Range("C7").Value
End With
End Sub
Related
So, I'm trying to create "cards" that the user can move around even when the the workbook is locked. Each card will contain info about a certain project.
The way I'm doing it:
Create a few shapes (an rectangle and a few labels and icons)
Group them
Cut the group
Paste as image
The problem is that when I paste as image, all labels loose their text, they change back to "label1".
If I run the code line by line, they don't lose the text.
I've tried already to add "time" between the cut and paste, adding some lines of code, moving the paste line to a separated sub, and even using Application.Wait(), but nothing worked.
I need to have them as an image (or one solid object - just a group doesn't work), because after the macro is finished, the worksheet is locked back again, and there is another macro to allow the user to move shapes even when the workbook is locked.
Here is a sample to show the problem.
Sub MyCode()
Set wkm = Workbooks(ThisWorkbook.Name)
Set wsm = wkm.Worksheets("TestSheet")
'Just two labels as exemple, the original code has more labels, more icons, and the rounded rectangle)
'The values for the constructors in the original code are defined by the user by a forms
Call GenerateLabel("plaseWork", "Name of the project", 14, 30)
Call GenerateLabel("whyCantYouJustWork", "Name of the user", 42, 30)
wsm.Shapes.Range(Array("plaseWork", "whyCantYouJustWork")).Group.Name = "myGroup"
Set freeSlot = wsm.Range("B10") 'Just a random cell, in the original code there is a function to define the position
Application.CutCopyMode = False
wsm.Shapes("myGroup").Cut
With wsm.Pictures.Paste
.left = freeSlot.left
.top = freeSlot.top
End With
Application.CutCopyMode = False
Set card = wsm.Pictures(wsm.Pictures.Count)
card.Name = "card" & projectName
End Sub
Sub GenerateLabel(labelDescription As String, projectName As String, top As Integer, left As Integer)
Set lbLabel = wsm.OLEObjects.Add(ClassType:="Forms.Label.1")
With lbLabel
.Name = labelDescription
.Object.BackStyle = fmBackStyleTransparent
.Width = 160
.top = top
.left = left
End With
With wsm
.OLEObjects(lbLabel.Name).Object.Caption = projectName
.Shapes(lbLabel.Name).Fill.Transparency = 1
End With
End Sub
What about using shapes with no outline or fill, in place of labels?
Sub MyCode()
Dim wsm As Worksheet, arr(0 To 1), grp As Shape
Set wkm = Workbooks(ThisWorkbook.Name)
Set wsm = wkm.Worksheets("TestSheet")
arr(0) = AddLabel(wsm, "Name of the project", 14, 30).Name
arr(1) = AddLabel(wsm, "Name of the user", 42, 30).Name
Set freeSlot = wsm.Range("B10") 'Just a random cell, in the original code there is a function to define the position
wsm.Shapes.Range(arr).Group.Cut
With wsm.Pictures.Paste
.left = freeSlot.left
.top = freeSlot.top
End With
Set card = wsm.Pictures(wsm.Pictures.Count)
card.Name = "card" & projectName
End Sub
'Add a shape to a worksheet, with the text provided.
' Return the added shape
Function AddLabel(ws As Worksheet, projectName As String, top As Integer, left As Integer)
Dim shp
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, left, top, 160, 30)
With shp
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
With .TextFrame2.TextRange.Characters
.Text = projectName
.Font.Fill.ForeColor.RGB = vbBlack
.Font.Size = 14
End With
End With
Set AddLabel = shp
End Function
I'm having problems in grouping shapes by name with VBA in Excel.
This happens because I have multiple shapes that can have the same name.
The following code can recreate my problem.
You can uncomment line OriginalShape.Name = "MyShape" to see the error.
Sub test()
' Create Original Shape
Dim OriginalShape As Shape
Set OriginalShape = Sheet1.Shapes.AddShape(msoShapeRectangle, 5, 20, 50, 50)
' Rename Shape to simulate my project
' OriginalShape.Name = "MyShape" ' Uncomment line to recreate problem
' Copy and Paste Shape (I believe there is no other way to do this)
OriginalShape.Copy
Sheet1.Paste Sheet1.Range("C2")
' Get Object of Last Pasted Shape
Dim CloneShape As Shape
Set CloneShape = Sheet1.Shapes(Sheet1.Shapes.Count)
' Group Shapes
Dim ShapeGroup As Shape
Set ShapeGroup = Sheet1.Shapes.Range(Array(OriginalShape.Name, CloneShape.Name)).Group
End Sub
I know I also have the possibility to use Shape indexes, like Sheet1.Shapes.Range(Array(1, 2)).Group, but this is doesn't seem a good way either, as I would need to store one more variable for each shape (the shape index) apart from the shape Object.
Is there a way to group shapes some other way, like through Object or ID.
I believe the best would be something like.
Set ShapeGroup = Sheet1.Shapes.Range(Array(OriginalShape, CloneShape)).Group
'OR
Set ShapeGroup = Sheet1.Shapes.Range(Array(OriginalShape.ID, CloneShape.ID)).Group
Like Tim Williams said: the code fails, as the group-array consists of equal names. What you need to do, is adding the index to the name while creating the shapes
This will work:
Sub test()
Const cntShapes As Long = 2
Dim i As Long, shp As Shape, cTarget As Range
Dim arrShapeNames(1 To cntShapes) As Variant
With Sheet1
For i = 1 To cntShapes
Set cTarget = .Cells(1, i) 'adjust this to your needs
Set shp = .Shapes.AddShape(msoShapeRectangle, cTarget.Left, cTarget.Top, 50, 50)
shp.Name = "MyShape." & i 'adding the index to the name makes it unique
arrShapeNames(i) = shp.Name
Next
End With
' Group Shapes
Dim ShapeGroup As Shape
Set ShapeGroup = Sheet1.Shapes.Range(arrShapeNames).Group
End Sub
I am using Application.Caller in a subroutine that I programmatically tied to the OnAction property of all the shapes I find on a worksheet. Application.Caller returns the name of the shape which initiated the call so that I can then obtain the appropriate shape object to process.
All of this is fine unless there is more than one shape on the sheet with the same name making it impossible to determine which is the caller. Excel manages the naming when inserting, copying and pasting shapes manually in a worksheet but these worksheets are populated through external apps which can cause this naming redundancy.
I am currently managing this by first scanning and renaming the redundant shapes so that I can identify them with the Application.Caller function. However, I do not want to rename them.
Code I've tried:
Set objShape = Application.Caller - unfortunately does not work
iShapeID = Application.Caller.ID - unfortunately does not work
iShapeID = ActiveSheet.Shapes(Application.Caller).ID - works but does not identify the correct caller when there are shapes with the same name
So, my question is: How can I obtain the proper Application.Caller shape object when there are redundantly named shapes on the worksheet?.
Put another way: Is there a way to cast the Application.Caller to a shape object without using the name of the shape returned by Application.Caller ideally using the ID property of the shape?
I don't think there is a an alternative for Application.Caller to return the ID property of the Shape or some other 'trick' to achieve what you want.
The work-around is to ensure that all your Shapes have unique names. If you have a sheet of names with duplicates you can quickly make them unique by re-naming them to preserve the original duplicate but add a suffix e.g. _1 to make them unique.
The sub could work like this (using a Dictionary to track the suffix value):
Sub MakeShapeNamesUnique(ws As Worksheet)
Dim shp As Shape
Dim dic As Object
Dim lng As Long
Set dic = CreateObject("Scripting.Dictionary")
'iterate shapes
For Each shp In ws.Shapes
' does shape name exist ?
If Not dic.Exists(shp.Name) Then
' add name to dictionary if not exists with counter of 0
dic.Add shp.Name, 0
Else
' found a duplicate
' increment counter
dic(shp.Name) = dic(shp.Name) + 1
' rename shape with suffix indicating dupe index
shp.Name = shp.Name & "_" & dic(shp.Name)
End If
Next shp
' job done - clean up the dictionary
Set dic = Nothing
End Sub
Here's the full test code that creates your issue and uses MakeShapeNamesUnique to work-around the problem. If you want to try it out, put it in a blank workbook because it will delete shapes out of the sheet before it starts:
Option Explicit
Sub Test1()
Dim ws As Worksheet
Dim shp As Shape
' reset shapes
Set ws = ThisWorkbook.Worksheets("Sheet1")
For Each shp In ws.Shapes
shp.Delete
Next shp
' add shape
With ws.Shapes.AddShape(msoShapeRectangle, 10, 10, 100, 100)
.Name = "Foo1"
.OnAction = "ShapeAction"
End With
' add another shape
With ws.Shapes.AddShape(msoShapeRectangle, 160, 10, 100, 100)
.Name = "Foo2"
.OnAction = "ShapeAction"
End With
' add another shape with duplicate name
With ws.Shapes.AddShape(msoShapeRectangle, 310, 10, 100, 100)
.Name = "Foo1"
.OnAction = "ShapeAction"
End With
' add another shape with duplicate name
With ws.Shapes.AddShape(msoShapeRectangle, 10, 160, 100, 100)
.Name = "Foo2"
.OnAction = "ShapeAction"
End With
' add another shape with duplicate name
With ws.Shapes.AddShape(msoShapeRectangle, 160, 160, 100, 100)
.Name = "Foo1"
.OnAction = "ShapeAction"
End With
' add another shape
With ws.Shapes.AddShape(msoShapeRectangle, 310, 160, 100, 100)
.Name = "Foo3"
.OnAction = "ShapeAction"
End With
' uniqueify shape names - comment out to replicate OP problem
MakeShapeNamesUnique ws
End Sub
Sub ShapeAction()
Dim shp As Shape
Set shp = Sheet1.Shapes(Application.Caller)
MsgBox " My name is: " & shp.Name & " and my ID is: " & shp.ID
End Sub
Sub MakeShapeNamesUnique(ws As Worksheet)
Dim shp As Shape
Dim dic As Object
Dim lng As Long
Set dic = CreateObject("Scripting.Dictionary")
'iterate shapes
For Each shp In ws.Shapes
' does shape name exist ?
If Not dic.Exists(shp.Name) Then
' add name to dictionary if not exists with counter of 0
dic.Add shp.Name, 0
Else
' found a duplicate
' increment counter
dic(shp.Name) = dic(shp.Name) + 1
' rename shape with suffix indicating dupe index
shp.Name = shp.Name & "_" & dic(shp.Name)
End If
Next shp
' job done - clean up the dictionary
Set dic = Nothing
End Sub
Counter must be unique, also when adding shapes between.
Sub MakeShapeNamesUnique(ws As Worksheet)
Dim shp As Shape
Dim dic As Object
Dim lng As Long
Set dic = CreateObject("Scripting.Dictionary")
'iterate shapes
For Each shp In ws.Shapes
' does shape name exist ?
If Not dic.Exists(shp.Name) Then
' add name to dictionary if not exists with counter of 0
dic.Add shp.Name, 0
Else
' found a duplicate
' increment counter (must be unique)
Do
dic(shp.Name) = dic(shp.Name) + 1
Loop Until Not dic.Exists(shp.Name & "_" & dic(shp.Name))
' rename shape with suffix indicating dupe index
shp.Name = shp.Name & "_" & dic(shp.Name)
End If
Next shp
' job done - clean up the dictionary
Set dic = Nothing
End Sub
In VBA for Excel 2007, I want to add a textbox to the active sheet and set its formula to a cell. My problem is that the AddTextbox function returns an object with typename Shape, not TextBox, so it does not have a Formula property to set. Instead, I ended up looping through all the textboxes to find the right one, then set its Formula. Is there a better way to do this?
Sub insertTextBoxWithFormula()
Set newTextBox = ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 200, 200, 150, 150)
newTextBox.Name = "New TextBox"
'newTextBox.Formula = "=$A$1" 'This is what I wanted to do
'This is what I did instead
For Each CurrentTextBox In ActiveSheet.TextBoxes
If CurrentTextBox.Name = "New TextBox" Then
CurrentTextBox.Formula = "=B3"
CurrentTextBox.Name = "Finished TextBox"
End If
Next CurrentTextBox
End Sub
You can index the TextBoxes collection using the name of the control. So your example can be abbreviated to:
ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 200, 200, 150, 150).Name = "New TextBox"
ActiveSheet.TextBoxes("New TextBox").Formula = "=$B$3"
Or this:
Dim newshp As Shape
Dim newtb As TextBox
Set newshp = ActiveSheet.Shapes.AddTextbox _
(msoTextOrientationHorizontal, 200, 200, 150, 150)
Set newtb = newshp.OLEFormat.Object
newtb.Formula = "$A$1"
i have problem with selecting combobox after creating it via shapes object. Can someone please help?
My code is
Dim comboBoxRange As Range
Set comboBoxRange = Sheets(axleDataWindowName).Range("F2:F4")
currentSheet.DropDowns.Add(20, 40, 100, 15).Name = "modifiedComboBox"
With currentSheet.Shapes("modifiedComboBox")
.Left = 450
.List comboBoxRange.Value
End With
You need to call currentSheet.Dropdowns("modifiedComboBox") instead of currentSheet.Shapes("modifiedComboBox"). Also use .AddItem instead of .List:
Dim comboBoxRange As Range
Set comboBoxRange = Sheets(axleDataWindowName).Range("F2:F4")
currentSheet.DropDowns.Add(20, 40, 100, 15).Name = "modifiedComboBox"
With currentSheet.Shapes("modifiedComboBox")
.Left = 450
.AddItem comboBoxRange.Value
End With