CODEWITHSUNDEEP
vbapowerpoint
Curiosity_Bug
Curiosity_Bug

Reputation: 79

How to group each shape in a selection of a PowerPoint slide using VBA?

I am working on a landscape diagram that has many shapes. I am trying to do following in a slide that has many shapes by selecting all the shapes at once (Ctrl + A) and perform grouping. If I do this manually by selecting the inbuilt group function present in PowerPoint, the shapes (red and yellow boxes) are not grouped, instead all four boxes are grouped as bunch.

I am trying to achieve the following: (Taking reference of example attached)

  1. Select all 4 shapes
  2. when macro is run, the boxes should be grouped (i.e yellow and red shapes should be paired as well as green and blue shapes)

Following is the code I tried for achieving this. But, only first two shapes in the selection were grouped where as other two are not.

Grouping

   Sub Grouping2()
   Dim V As Long
   Dim oSh1 As Shape
   Dim oSh2 As Shape
   Dim Shapesarray() As Shape
   Dim oGroup As Shape
   Dim oSl As Slide


  Call rename
  On Error Resume Next
  If ActiveWindow.Selection.ShapeRange.Count < 2 Then
  MsgBox "Select at least 2 shapes"
  Exit Sub
  End If
 ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)


For V = 1 To ActiveWindow.Selection.ShapeRange.Count

     Set oSh1 = ActiveWindow.Selection.ShapeRange(V)
     Set oSh2 = ActiveWindow.Selection.ShapeRange(V + 1)

         If ShapesOverlap(oSh1, oSh2) = True Then

             Set Shapesarray(V) = oSh1
             Set Shapesarray(V + 1) = oSh2
              ' group items in array
             ActivePresentation.Slides(1).Shapes.Range(Array(oSh1.Name, oSh2.Name)).Group


               'else move to next shape in selction range and check
          End If

 V = V + 1
 Next V
End Sub


Sub rename()
Dim osld As Slide
Dim oshp As Shape
Dim L As Long
Set osld = ActiveWindow.Selection.SlideRange(1)
For Each oshp In osld.Shapes
If Not oshp.Type = msoPlaceholder Then
L = L + 1
oshp.Name = "myShape" & CStr(L)
End If
Next oshp
End Sub

Upvotes: 1

Views: 2212

Answers (1)

Domenic
Domenic

Reputation: 8104

In the first loop iteration, when the first two shapes are grouped, all of the shapes get de-selected. And so in your subsequent loop, you would have received an error, but since you enabled error handling with On Error Resume Next without disabling it afterwards, the error is hidden.

Error Handling After you've enabled error handling and tested whether more than one shape has been selected, you should disable it. Should you need it at some point, it can be enabled again.

On Error Resume Next
If ActiveWindow.Selection.ShapeRange.Count < 2 Then
    MsgBox "Select at least 2 shapes"
    Exit Sub
End If
On Error GoTo 0

Array Assignment Assign each of the selected shapes to an element within the array.

Dim Shapesarray() As Shape
ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)

Dim V As Long

For V = 1 To ActiveWindow.Selection.ShapeRange.Count
    Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
Next V

Grouping Loop through the array, test whether the shapes within each pair overlap, and then make sure that neither are already part of a group.

For V = LBound(Shapesarray) To UBound(Shapesarray) - 1
    If ShapesOverlap(Shapesarray(V), Shapesarray(V + 1)) Then
        If Not Shapesarray(V).Child And Not Shapesarray(V + 1).Child Then
            ActiveWindow.View.Slide.Shapes.Range(Array(Shapesarray(V).Name, Shapesarray(V + 1).Name)).Group
        End If
    End If
Next V

The complete code would be as follows...

   Sub Grouping2()

    'Call rename

    On Error Resume Next
    If ActiveWindow.Selection.ShapeRange.Count < 2 Then
        MsgBox "Select at least 2 shapes"
        Exit Sub
    End If
    On Error GoTo 0

    Dim Shapesarray() As Shape
    ReDim Shapesarray(1 To ActiveWindow.Selection.ShapeRange.Count)
    Dim V As Long

    For V = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set Shapesarray(V) = ActiveWindow.Selection.ShapeRange(V)
    Next V

    For V = LBound(Shapesarray) To UBound(Shapesarray) - 1
        If ShapesOverlap(Shapesarray(V), Shapesarray(V + 1)) Then
            If Not Shapesarray(V).Child And Not Shapesarray(V + 1).Child Then
                ActiveWindow.View.Slide.Shapes.Range(Array(Shapesarray(V).Name, Shapesarray(V + 1).Name)).Group
            End If
        End If
    Next V

End Sub

Upvotes: 1

Related Questions