继我的出色回答之后上一个问题 https://stackoverflow.com/questions/74339247/how-to-rename-shapes-within-grouped-groups-in-powerpoint-with-vba，我试图从一组原始的分组对中创建两组，一组由形状和一组文本框组成，每组由一个形状和一个文本框组成。
我尝试创建两个数组，每个类别一个，通过调整上一个问题的答案中的代码并查看我发现的类似问题，例如here https://stackoverflow.com/questions/65400944/grouping-an-array-of-shapes，但是我想出的方法不起作用：宏调用的函数在最后一步停止（当我尝试对数组进行分组时，即Set GroupedShapes = oSlide.shapes.Range(ShapeArray).Group）有错误-2147024809 (80070057)': Shapes(uknown member): Illegal value. Bad type: expected ID array of Variants, Integers, Longs, or Strings.我尝试留下空白括号 -->Set GroupedShapes = oSlide.shapes.Range(ShapeArray()).Group据我了解，那里缺少一些东西，但我得到了同样的错误，也没有...Range(ShapeArray(1 to .shpRng))...当我收到提示时，我应该用逗号分隔值。然而，我什至不确定如果这个问题得到解决，剩下的部分是否真的有效。有人可以建议吗？
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
编辑：我刚刚尝试过以下内容，但我得到了Type mismatch
Set GroupedShapes = oSlide.shapes.Range(indicesShapes(ShapeArray)).Group
Set GroupedText = oSlide.shapes.Range(indicesText(TextArray)).Group
EDIT2:
我回到我所指的答案，意识到我没有添加循环来取消分组到“核心”，直到没有剩余的组为止。然后，我更改了数组的顺序并将它们放置在此之后，天真地认为通过将形状和文本框的变量加倍，我会得到预期的结果，但第一对形状只会取消分组。我的想法是获取形状和文本框的 id，这样它们就会相应地分组，但是尽管我添加了循环，但下面的内容在第一对处停止，直到有组为止，所以最后一行Set GroupedText = oSlide.shapes.Range(indicesText).Group给出错误，表示在形状范围内必须至少有两个对象。
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
预期结果
