Formes de groupe à la même hauteur sur plusieurs lignes dans Powerpoint à l'aide de VBA

Question

Je souhaite créer une macro VBA dans PPT pour Grouper des formes de même hauteur sur plusieurs lignes dans Powerpoint à l'aide de VBA. Mon premier pas serait idéalement comme cette image: Group Textboxes row wise

Il y a une matrice de zones de texte dans plusieurs lignes et colonnes uniformément réparties verticalement & horizontalement. Je veux sélectionner toutes les formes et exécuter une macro pour regrouper les zones de texte en lignes multiples. Le code ci-dessous est copié et pas encore final, Appréciez toute aide, des extraits pour cela, merci beaucoup.

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 

Answer 1

Deux ou trois choses qui ne peuvent pas vous donner pleinement ce que vous êtes après, mais ça va vous faire économiser du mal à la ligne:

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 

Answer 2

Je n'ai pas le temps en ce moment à écrire/test de code, mais si je devais le faire, je commencer avec quelque chose comme cet extrait que j'avais un autre projet:

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