1

I want to create a VBA macro in PPT to Group shapes in same height across multiple rows in Powerpoint using VBA. My initial step would be ideally like this image: Group Textboxes row wise

There is a matrix of textboxes in many rows and columns evenly distributed vertically & horizontally. I want to select all the shapes altogether and run a macro to group the textboxes row wise, into multiple rows. Code below is copied and not final yet, Appreciate any help, snippets for this, thanks a lot.

Sub GroupSameHeightObjects()

  ' Dimension the variables.
  Dim shapeObject As shape
  Dim lSlideNumber As Long
  Dim strPrompt, strTitle As String
  Dim ShapeList() As String
  Dim count As Long

  ' Initialize the counter.
  count = 0

  ' Make sure PowerPoint is in slide view.
  If ActiveWindow.ViewType <> ppViewSlide Then

     ' Set up the error message.
     strPrompt = "You must be in slide view to run this macro." _
        & " Change to slide view and run the macro again."
     strTitle = "Not In Slide View"

     ' Display the error message.
     MsgBox strPrompt, vbExclamation, strTitle

     ' Stop the macro.
     End

  End If

  ' Get the current slide number.
  lSlideNumber = ActiveWindow.Selection.SlideRange.SlideNumber

  ' Loop through the shapes on the slide.
  For Each shapeObject In _
     ActivePresentation.Slides(lSlideNumber).Shapes

     ' See whether shape is a placeholder.
     If shapeObject.Type <> msoPlaceholder Then

        ' Increment count if the shape is not a placeholder.
        count = count + 1

        ' Get the name of the shape and store it in the ShapeList
        ' array.
        ReDim Preserve ShapeList(1 To count)
        ShapeList(count) = shapeObject.Name

     End If

  Next shapeObject

  ' If more than 1 object (excluding a placeholder object) is found,
  ' group the objects.
  If count > 1 Then
     With ActivePresentation.Slides(lSlideNumber).Shapes

        ' Group the shapes together.
        .Range(ShapeList()).Group.Select
     End With
  Else

     Select Case count

        ' One shape found.
        Case 1

           ' Set up the message.
           strPrompt = "Only one shape found." _
              & " You need at least two shapes to group."
           strTitle = "One Shape Available"

        ' Zero shapes found.
        Case 0

           ' Set up the message.
           strPrompt = "No shapes found. You need to have at " _
              & "least two shapes, excluding placeholders."
           strTitle = "No Shapes Available"

        ' An error occurred.
        Case Else

           ' Set up the message.
           strPrompt = "The macro found an error it could not correct."
           strTitle = "Error"

     End Select

     ' Display the message.
     MsgBox strPrompt, vbExclamation, strTitle

  End If

End Sub
Pᴇʜ
  • 56,719
  • 10
  • 49
  • 73
Jegan
  • 63
  • 1
  • 9
  • just a note on your code (this is no solution to your question): Be sure you know the difference between `End` and `Exit Sub`. `End` does actually end **all** macros immediately but `Exit Sub` will behave like jumping to the end of the current procedure and just exit this current sub without affecting any other codes (which is probably what you want). – Pᴇʜ Oct 05 '17 at 13:43

2 Answers2

1

I don't have time right now to write/test any code, but if I had to do this, I'd start with something like this snippet I had from another project:

Sub GroupCertainShapes()

    Dim x As Long
    Dim sTemp As String
    Dim aShapeList() As String
    Dim lShapeCount As Long

    With ActivePresentation.Slides(1)
        ' iterate through all shapes on the slide
        ' to get a count of shapes that meet our condition
        For x = 1 To .Shapes.Count
            ' Does the shape meet our condition? count it.
            If .Shapes(x).Type = msoAutoShape Then
                lShapeCount = lShapeCount + 1
            End If
        Next

        ' now we know how many elements to include in our array,
        ' so redim it:
        ReDim aShapeList(1 To lShapeCount)

        ' Reset the shape counter
        lShapeCount = 0

        ' Now add the shapes that meet our condition
        ' to the array:
        For x = 1 To .Shapes.Count
            ' apply some criterion for including the shape or not
            If .Shapes(x).Type = msoAutoShape Then
                lShapeCount = lShapeCount + 1
                aShapeList(lShapeCount) = .Shapes(x).Name
            End If
        Next

        ' and finally form a group from the shapes in the array:
        If UBound(aShapeList) > 0 Then
            .Shapes.Range(aShapeList).Group
        End If

    End With
End Sub
Steve Rindsberg
  • 14,442
  • 1
  • 29
  • 34
  • aShapeList(lShapeCount) = .Shapes(x).Name in this line, Is there are way to get the shape without using its name, since in my selection there are multiple shapes with the same name, some parameter like id can help. – Jegan Oct 22 '17 at 08:26
  • 1
    If you can select multiple shapes with the same name, your slide is corrupt; normally PPT doesn't allow this, but sometimes it creates them on its own; a bug. You may need to correct this situation before you can get down to business. Rename the shapes to e.g. Originalname --> Originalname_1, -2 etc. – Steve Rindsberg Oct 22 '17 at 15:07
  • @SteveRindsberg, is there a limitation to the lenght of the string `aShapeList() `? I used part of this code here (https://stackoverflow.com/a/74501231/18247317) but with a high number of shapes it fails. I tried this edit https://stackoverflow.com/a/22257354/18247317 `Dim aShapeList As String() * 1024 ` but I get a Compile error that I cannot assign it. Or shall I open another question..? – Oran G. Utan Nov 23 '22 at 17:32
  • @Bradipo, aShapeList is not a string it's an ARRAY of strings. When it fails, what line of code are you on, what's the value of the array index (the number in parentheses) and what's the exact error message? – Steve Rindsberg Nov 24 '22 at 19:07
  • @SteveRindsberg, Now I cannot reproduce the error anymore... But I think I found it, apologies for disturbing. Some textboxes (they come from .SVG files) somehow got broken in two lines or were doubled, and this was giving me `Run-time error "-2147467259 (80004005)" Method 'Group' of Object 'ShapeRange' failed`. I had also tried to change .name to .Id (I had some drawing with textboxes that had the same name) but I was getting `Run-time error "-2147188160 (80048240)" Item 233` (number changing from set of shapes) `not found in the Shapes Collection` (which is probably normal). – Oran G. Utan Nov 24 '22 at 21:14
0

A couple of things that may not give you fully what you're after but that'll save you some trouble down the line:

   Sub GroupSameHeightObjects()

  ' Dimension the variables.
  Dim shapeObject As shape
  Dim lSlideNumber As Long

  ' This will dim strPrompt as a variant
  ' Dim strPrompt, strTitle As String
  Dim strPrompt as string, strTitle as string

  Dim ShapeList() As String
  Dim count As Long

  ' Initialize the counter.
  count = 0

  ' Make sure PowerPoint is in slide view.
  If ActiveWindow.ViewType <> ppViewSlide Then

     ' Set up the error message.
     strPrompt = "You must be in slide view to run this macro." _
        & " Change to slide view and run the macro again."
     strTitle = "Not In Slide View"

     ' Display the error message.
     MsgBox strPrompt, vbExclamation, strTitle

     ' Stop the macro.
     ' See previous comment
     'End
     Exit Sub

  End If

  ' Get the current slide number.
  ' Nope, you want the SlideIndex; SlideNumber gives you the number that'll
  ' appear when you use PPT's slide numbering features; if the user sets the 
  ' starting number to something other than 1, your code will break
  'lSlideNumber = ActiveWindow.Selection.SlideRange.SlideNumber
   lSlideNumber = ActiveWindow.Selection.SlideRange.SlideIndex

  ' Loop through the shapes on the slide.
  For Each shapeObject In _
     ActivePresentation.Slides(lSlideNumber).Shapes

     ' See whether shape is a placeholder.
     If shapeObject.Type <> msoPlaceholder Then

        ' Increment count if the shape is not a placeholder.
        count = count + 1

        ' Get the name of the shape and store it in the ShapeList
        ' array.
        ' I've learned not to trust shape names in PPT
        ' I'd dim ShapeList as an array of shapes and then
        ' Set ShapeList(count) = shapeObject
        ReDim Preserve ShapeList(1 To count)
        ShapeList(count) = shapeObject.Name

     End If

  Next shapeObject

' You could include this next bit in the following Case selector,
' Case > 1 ... etc.    
      ' If more than 1 object (excluding a placeholder object) is found,
      ' group the objects.
      If count > 1 Then
         With ActivePresentation.Slides(lSlideNumber).Shapes

        ' Group the shapes together.
        .Range(ShapeList()).Group.Select
     End With
  Else

     Select Case count

        ' One shape found.
        Case 1

           ' Set up the message.
           strPrompt = "Only one shape found." _
              & " You need at least two shapes to group."
           strTitle = "One Shape Available"

        ' Zero shapes found.
        Case 0

           ' Set up the message.
           strPrompt = "No shapes found. You need to have at " _
              & "least two shapes, excluding placeholders."
           strTitle = "No Shapes Available"

        ' An error occurred.
        Case Else

           ' Set up the message.
           strPrompt = "The macro found an error it could not correct."
           strTitle = "Error"

     End Select

     ' Display the message.
     MsgBox strPrompt, vbExclamation, strTitle

  End If

End Sub
Steve Rindsberg
  • 14,442
  • 1
  • 29
  • 34
  • Hi Steve, Thats a good catch, Thanks. I feel privileged to get suggestions from you. Could you please help with the core piece of the code for this purpose. Ideally, i want to select a matrix of shapes in a slide, within that selection, only the shapes with same top value must be grouped individually into multiple rows. Thank you so much, its a great favour, i'm in deadlock for days at this junction. – Jegan Oct 20 '17 at 10:57