Following the excellent answer to my previous question, I am trying to make two groups, one made of shapes and one of textboxes, out of an original group of grouped pairs, each composed of a shape and a textbox.
I tried creating two arrays, one for each category, by adapting the code from the answer to the previous question and looking at similar questions I found, like here, however what I came up is not working: the function called by the macro stops at the last step (when I try to group the array i.e. Set GroupedShapes = oSlide.shapes.Range(ShapeArray).Group) with error -2147024809 (80070057)': Shapes(uknown member): Illegal value. Bad type: expected ID array of Variants, Integers, Longs, or Strings. I tried leaving blank brackets --> Set GroupedShapes = oSlide.shapes.Range(ShapeArray()).Group as from what I understand something is missing in there, but I get the same error, nor does ...Range(ShapeArray(1 to .shpRng))... work as I receive the prompt I should separate values by a comma. However, I am not even sure that if this is fixed the rest will actually work. Could someone please advise?
Sub GiveNamesToShapes()
Dim oSlide As slide
Set oSlide = ActivePresentation.Slides(ActiveWindow.View.slide.SlideIndex)
Dim shp As Shape
For Each shp In oSlide.shapes
If shp.Type = msoGroup Then
NameGroup shp
End If
Next shp
End Sub
Function NameGroup(ByVal oShpGroup As Object) As Long
Dim groupName As String, shp As Shape, shpRng As ShapeRange, txt As String
Dim TextArray() As Variant 'these are the variables I created
Dim ShapeArray() As Variant
Dim GroupedShapes As Shape
Dim GroupedText As Shape
Dim i As Integer 'these are the variables I created
Dim y As Integer
Dim Shp_Cntr As Double
Dim Shp_Mid As Double
Dim ShapeLeft As Double
Dim ShapeRight As Double
Dim ShapeWidth As Double
Dim ShapHeight As Double
groupName = oShpGroup.name
Dim oSlide As slide: Set oSlide = oShpGroup.Parent
Set shpRng = oShpGroup.Ungroup
For Each shp In shpRng
If Not shp.Type = msoGroup Then
If shp.TextFrame.HasText = msoTrue Then _
txt = shp.TextFrame.TextRange.text
End If
Next shp
For Each shp In shpRng
If Not shp.Type = msoGroup Then
If shp.TextFrame.HasText = msoFalse Then
With shp
'here is the first array i created (shapes)
Dim indicesShapes() As Long, z As Long: ReDim indicesShapes(LBound(ShapeArray) To UBound(ShapeArray))
For i = LBound(ShapeArray) To UBound(ShapeArray)
For z = 1 To oSlide.shapes.Count
Set oSlide.shapes(z) = ShapeArray(i) 'Then indices(i) = j: Exit For
Next z
Next i
'up to here
End With
ShapeLeft = shp.Left
ShapeTop = shp.Top
ShapeWidth = shp.Width
ShapeHeight = shp.Height
Shp_Cntr = ShapeLeft + ShapeWidth / 2
Shp_Mid = ShapeTop + ShapeHeight / 2
shp.name = txt
Else
With shp
'this is the second Array (for textboxes)
Dim indicesText() As Long, p As Long: ReDim indicesText(LBound(TextArray) To UBound(TextArray))
For y = LBound(TextArray) To UBound(TextArray)
For p = 1 To oSlide.shapes.Count
Set oSlide.shapes(p) = TextArray(y) 'Then indices(i) = j: Exit For
Next p
Next y
'up to here
.TextFrame.WordWrap = False
.TextFrame.AutoSize = ppAutoSizeShapeToFitText
.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignCenter
.TextFrame.VerticalAnchor = msoAnchorMiddle
.Left = Shp_Cntr - .Width / 2
.Top = Shp_Mid - Height / 2
End With
End If
End If
Next shp
'here is where I try to group the items in the arrays and I get the error
Set GroupedShapes = oSlide.shapes.Range(ShapeArray).Group
Set GroupedText = oSlide.shapes.Range(TextArray).Group
End Function
EDIT: I have just tried the below, but I get Type mismatch
Set GroupedShapes = oSlide.shapes.Range(indicesShapes(ShapeArray)).Group
Set GroupedText = oSlide.shapes.Range(indicesText(TextArray)).Group
EDIT2:
I went back to the answer I am referring to and realized I did not add the loop to ungroup to the "core", that is till there are no groups left. I then changed the order of the arrays and placed them after this, naively thinking that by doubling the variables for shapes and textboxes I would get the expected result, but the first pair of shapes only gets ungrouped. The idea I had was to get the ids of shapes and textboxes, so they would be grouped accordingly, however the below stops at the first pair despite the loop I have added until there are groups so the last line Set GroupedText = oSlide.shapes.Range(indicesText).Group gives error saying that in the shape range there must be at least two objects.
Sub GiveNamesToShapes()
Dim oSlide As slide
Set oSlide = ActivePresentation.Slides(ActiveWindow.View.slide.SlideIndex)
Dim shp As Shape
For Each shp In oSlide.shapes
If shp.Type = msoGroup Then
NameGroup shp
End If
Next shp
End Sub
Function NameGroup(ByVal oShpGroup As Object) As Long
Dim groupName As String, shp As Shape, shpRng As ShapeRange, txt As String
Dim TextArray() As Variant
Dim ShapeArray() As Variant
Dim GroupedShapes As Shape
Dim GroupedText As Shape
groupName = oShpGroup.name
Dim oSlide As slide: Set oSlide = oShpGroup.Parent
Set shpRng = oShpGroup.Ungroup
For Each shp In shpRng
If Not shp.Type = msoGroup Then
If shp.TextFrame.HasText = msoTrue Then _
txt = shp.TextFrame.TextRange.text
End If
Next shp
For Each shp In shpRng
If Not shp.Type = msoGroup Then
If shp.TextFrame.HasText = msoFalse Then
shp.name = txt
End If
End If
Next shp
Dim Shapeids() As Long, i As Long: ReDim Shapeids(1 To shpRng.Count): i = 1
Dim Textids() As Long, y As Long: ReDim Textids(1 To shpRng.Count): y = 1
For Each shp In shpRng
Do While shp.Type = msoGroup 'I added this loop to ungroup recursively, but it does not go through all groups, it works only on the first one
Call NameGroup(shp)
Loop
If shp.TextFrame.HasText = msoTrue Then
Textids(y) = shp.id: y = y + 1
ElseIf shp.TextFrame.HasText = msoFalse Then
Shapeids(i) = shp.id: i = i + 1
End If
Next shp
Dim Textindices() As Long, p As Long: ReDim Textindices(LBound(Textids) To UBound(Textids))
For y = LBound(Textids) To UBound(Textids)
For p = 1 To oSlide.shapes.Count
If oSlide.shapes(p).id = Textids(y) Then Textindices(y) = p: Exit For
Next p
Next y
Dim Shapeindices() As Long, z As Long: ReDim Shapeindices(LBound(Shapeids) To UBound(Shapeids))
For i = LBound(Shapeids) To UBound(Shapeids)
For z = 1 To oSlide.shapes.Count
If oSlide.shapes(z).id = Shapeids(i) Then Shapeindices(i) = z: Exit For
Next z
Next i
Set GroupedShapes = oSlide.shapes.Range(Shapeindices).Group 'here it stops and it says there must be two objects to make a group, only the first pair is ungroupd (the primary, big group containing all is gone) while all oteher pairs are still grouped
Set GroupedText = oSlide.shapes.Range(Textindices).Group
End Function
As is
Expected Result
