I have a grouped shape in a document:
Dim doc As Word.Document
Set doc = Documents("dlr-overview.docx")
Dim firstShape As Word.Shape
Set firstShape = doc.Shapes(1)
AutoShapeType on firstShape returns -2, or msoShapeMixed; and firstShape.GroupItems.Count returns 25:
Debug.Print firstShape.AutoShapeType
Debug.Print firstShape.GroupItems.Count
I can iterate over the shapes in firstShape.GroupItems without casting to Shape. TypeName returns "Shape" for each element, and the AutoShapeType property returns 5, or msoShapeRoundedRectangle:
Dim x As Variant
For Each x In firstShape.GroupItems
Debug.Print TypeName(x)
Debug.Print x.AutoShapeType
Next
But when I try to cast each element to Shape, I get Type mismatch on the first iteration of the For Each:
Dim subshape As Shape
For Each subshape In firstShape.GroupItems
Debug.Print subshape.Left
Next
How can I extract information about an individual shape from the grouped shape?
It seems that it is impossible to enumerate using a Shape variable over the GroupShapes object returned from Shape.GroupItems. The following also errors within the iteration:
Dim shapes As GroupShapes
Set shapes = firstShape.GroupItems
Dim shp As Shape
For Each shp In shapes
Debug.Print shp.Name
Next
Apparently the returned elements are something other than Word.Shape objects, even though the TypeName function returns "Shape" for such objects.
However, if I access the elements via the Item property of the GroupShapes collection, or via the default property, they are returned as Word.Shape objects, and can be casted to Word.Shape:
Dim i As Integer
For i = 1 To firstShape.GroupItems.Count
Dim shp As Shape
Set shp = firstShape.GroupItems(i)
Debug.Print shp.Name
Next
Related
Recently, in an interview I encountered a question in VBA. The question is:
Write a program to sort the shapes in a worksheet, like for example : I have various shapes like circle, triangle, rectangle, pentagon... This needs to be sorted and placed one below the other.
I tried with Shapes object and msoshapeRectangle method. But it didnt work.
Could you please tell me is this possible to be done?
Thanks
It was an interesting challenge, so I did it. Might as well post the result (commented for clarity):
Sub tgr()
'There are 184 total AutoShapeTypes
'See here for full list
'https://msdn.microsoft.com/VBA/Office-Shared-VBA/articles/msoautoshapetype-enumeration-office
Dim aShapeTypes(1 To 184) As String
Dim ws As Worksheet
Dim Shp As Shape
Dim i As Long, j As Long
Dim vShpName As Variant
Dim dLeftAlign As Double
Dim dTopAlign As Double
Dim dVerticalInterval As Double
Dim dHorizontalInterval As Double
Dim dPadding As Double
Set ws = ActiveWorkbook.ActiveSheet
'Sort order will be by the AutoShapeType numerical ID
'Using this, shapes will be sorted in this order (incomplete list for brevity):
' Rectangle, Parallelogram, Trapezoid, Diamond, Rounded rectangle, Octagon, Isosceles triangle, Right triangle, Oval, Hexagon
'Note that you can use a Select Case to order shapes to a more customized list
'I use this method to put the -2 (indicates a combination of the other states) at the bottom of the sort order
For Each Shp In ws.Shapes
Select Case Shp.AutoShapeType
Case -2: aShapeTypes(UBound(aShapeTypes)) = aShapeTypes(UBound(aShapeTypes)) & "||" & Shp.Name
Case Else: aShapeTypes(Shp.AutoShapeType) = aShapeTypes(Shp.AutoShapeType) & "||" & Shp.Name
End Select
Next Shp
'Now that all shapes have been collected and put into their sort order, perform the actual sort operation
'Adjust the alignment and vertical veriables as desired
'The Padding variable is so that the shapes don't start at the very edge of the sheet (can bet set to 0 if that's fine)
'I have it currently set to sort the shapes vertically, but they can be sorted horizontally by uncommenting those lines and commenting out the vertical sort lines
dPadding = 10
dLeftAlign = 5
dTopAlign = 5
dVerticalInterval = 40
dHorizontalInterval = 40
j = 0
For i = LBound(aShapeTypes) To UBound(aShapeTypes)
If Len(aShapeTypes(i)) > 0 Then
For Each vShpName In Split(Mid(aShapeTypes(i), 3), "||")
With ws.Shapes(vShpName)
'Vertical Sort
.Left = dLeftAlign
.Top = j * dVerticalInterval + dPadding
'Horizont Sort
'.Top = dTopAlign
'.Left = j * dHorizontalInterval + dPadding
End With
j = j + 1
Next vShpName
End If
Next i
End Sub
I've the following code:
Dim headerTextboxes(2) As Shape
Dim currSlide As Slide
Set currSlide = Application.ActiveWindow.View.Slide
' Pseudocode
' Set currSlide = [null, null, null]
For i = 0 to 2
headerTextboxes(i) = currSlide.Shapes.AddTextbox(...)
Next i
I'm getting the error Object variable or With block variable not set. After some research, I believe it's because no array has actually been assigned to headerTextboxes yet.
The pseudocode in the comments is that I want to do. What's the correct implementation for it? All I can find online is to initialise either a zero-length array or a static length array with existing elements.
You need to use the Set keyword to when setting a reference to an Object. Since headerTextboxes is an array of Shape Objects, every element must use Set to assign a reference to a Shape.
Dim headerTextboxes(2) As Shape
Dim currSlide As Slide
Set currSlide = Application.ActiveWindow.View.Slide
' Pseudocode
' Set currSlide = [null, null, null]
For i = 0 To 2
Set headerTextboxes(i) = currSlide.Shapes.AddTextbox(...)
Next i
I am trying to create a dynamic number of variables in VBA based on the value in a cell.
Essentially what I'd like to end up with is something like Team1, Team2... to TeamX.
Any help is greatly appreciated
Dim i, x As Integer
Set x = Range("J4").Value
Dim Team(1 To x) As String
Dim Manager(1 To x) As String
Range("A3").Select
For i = 1 To x
Dim Team(i) As Integer
A dictionary would probably help in this case, it's designed for scripting, and while it won't let you create "dynamic" variables, the dictionary's items are dynamic, and can serve similar purpose as "variables".
Dim Teams as Object
Set Teams = CreateObject("Scripting.Dictionary")
For i = 1 To x
Teams(i) = "some value"
Next
Later, to query the values, just call on the item like:
MsgBox Teams(i)
Dictionaries contain key/value pairs, and the keys must be unique. Assigning to an existing key will overwrite its value, e.g.:
Teams(3) = "Detroit"
Teams(3) = "Chicago"
Debug.Print Teams(3) '## This will print "Chicago"
You can check for existence using the .Exist method if you need to worry about overwriting or not.
If Not Teams.Exist(3) Then
Teams(3) = "blah"
Else:
'Teams(3) already exists, so maybe we do something different here
End If
You can get the number of items in the dictionary with the .Count method.
MsgBox "There are " & Teams.Count & " Teams.", vbInfo
A dictionary's keys must be integer or string, but the values can be any data type (including arrays, and even Object data types, like Collection, Worksheet, Application, nested Dictionaries, etc., using the Set keyword), so for instance you could dict the worksheets in a workbook:
Dim ws as Worksheet, dict as Object
Set dict = CreateObject("Scripting.Dictionary")
For each ws in ActiveWorkbook.Worksheets
Set dict(ws.Name) = ws
Next
This will get you started. But before you start I recommend watching these WiseOwlTutorials tutorial on Youtube:
Selecting Cells (Range, Cells, Activecell, End, Offset)
Worksheets, Charts and Sheets
Variables
Arrays
Dim i, x As Integer
x = Range("J4").Value
Dim Team() As Integer
Dim Manager() As String
ReDim Team(1 To x) As Integer
ReDim Manager(1 To x) As String
Range("A3").Select
For i = 1 To x
Team(i) = i
Next
I have a PowerPoint slide with 5 shapes on it. I would like to do different things with theses shapes in a macro. How can I change one of these shapes by using the shape ID? For example, I have two shapes with a name of "Title 1" but I want to use the one with an ID of 15.
Here is my code:
Sub size_n_spread_v()
Dim j As Integer
Dim sld As Slide
Dim SldId As Long
gap = std_gap
SldId = ActiveWindow.View.Slide.SlideIndex
Set sld = ActivePresentation.Slides(SldId)
Call SortMultArray
new_dim = (total_dim - gap * (lngRow - 1)) / lngRow
'This works but is not specific:
'sld.Shapes.("Title 1").Height = new_dim
'This would hopefully be specific but the syntax does not work Please HELP!
'sld.Shapes.("Title 1").Id(15).Height = new_dim
End Sub
Does someone know the right syntax to change the shape via ID?
I don't know of a way, but you could write a simple helper function that you could then use throughout your project to make things easier on yourself. Something like this would work:
Public Function GetShapeById(s As Slide, n As String, id As Long) As Shape
Dim objShape As Shape
For Each objShape In s.Shapes
If StrComp(objShape.Name, n, vbTextCompare) = 0 And objShape.Id = id Then
Set GetShapeById = objShape
Exit Function
End If
Next
End Function
Then you could use it like so:
Sub size_n_spread_v()
....
' Instead of:
sld.Shapes.("Title 1").Id(15).Height = new_dim
' Use:
GetShapeById(sld, "Title 1", 15).Height = new_dim
End Sub
The function mentioned above is the only way to get a shape by Id. You have to search through the Shapes collection as there is no equivalent ShapeIndex as there is for SlideIndex. The other solution to find a specific shape is to uniquely identify shapes by adding your own Tag but this is a more complex solution.
I have a line (=autoshape) drawing object on an Excel spreadsheet. I want to determine which cell it "points" to. For this I need to know the coordinates of the start and end points.
I can use .Top, .Left, .Width, .Height to determine bounding rectangle, but the line may be in 2 different positions in that rectangle.
To do this you must use the members HorizontalFlip and VerticalFlip. The following function should do what you want:
Function CellFromArrow(ByVal s As Shape) As Range
Dim hFlip As Integer
Dim vFlip As Integer
hFlip = s.HorizontalFlip
vFlip = s.VerticalFlip
Select Case CStr(hFlip) & CStr(vFlip)
Case "00"
Set CellFromArrow = s.BottomRightCell
Case "0-1"
Set CellFromArrow = Cells(s.TopLeftCell.Row, s.BottomRightCell.Column)
Case "-10"
Set CellFromArrow = Cells(s.BottomRightCell.Row, s.TopLeftCell.Column)
Case "-1-1"
Set CellFromArrow = s.TopLeftCell
End Select
End Function
This code is tested in Excel 2010. Seems to work. Hope this helps!
EDIT:
If you have to worry about shapes contained in groups, then it seems the only solution is to ungroup, iterate through the shapes and then regroup. Something like the following:
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Type = msoGroup Then
Dim oldName as String
Dim sGroup As GroupShapes
Dim GroupMember as Shape
Set sGroup = s.GroupItems
oldName = s.Name 'To preserve the group Name
s.Ungroup
For Each GroupMember in sGroup
'DO STUFF
Next
Set s = sGroup.Range(1).Regroup 'We only need to select one shape
s.Name = oldName 'Rename it to what it used to be
End If
Next
You can refer to ShapeRange Documentation for more info on the Regroup method.
Let me know if this works for you!