CODEWITHSUNDEEP
vbapowerpoint
LCsa
LCsa

Reputation: 657

Get *all* shapes (including nested groups) in active presentation

My question comes from the need to change all text fonts the a specific font A. I know that there is a "Change font..." option in PowerPoint, but it forces me to pick a "from font" and a "to font". In my case there are several different fonts which should a be changed to font "X". Thus I wrote the following VBA macro.

Private Sub Set_Font_Of_All_TextFrames(oShp As Shape, font As String)
' Go through all shapes on all slides. This is a recurisve function. First call needs to pass "Nothing" to oShp.
' Any font in every textframe that is not "font" will be set to "font".
' The recursion is necessary in order to go through groups.
' BUG/TODO: Text in Master is not included so far!

    Dim sld As Slide
    Dim shp As Shape
    Dim i As Integer

    If oShp Is Nothing Then ' first subroutine call
        For Each sld In ActivePresentation.Slides
            For Each shp In sld.Shapes
                If shp.Type = msoGroup Then
                    Set_Font_Of_All_TextFrames shp, font ' recursive call in case of group
                Else
                    Set_Font shp, font ' else change font
                End If
            Next shp
        Next sld
    ' in case of recursive calls:
    ElseIf oShp.Type = msoGroup Then
        For i = 1 To oShp.GroupItems.Count()
            Set shp = oShp.GroupItems.Item(i)
            Set_Font_Of_All_TextFrames shp, font ' another recursive call in case of group; will repeat this branch in case of subgroup
        Next
    Else
        Set shp = oShp
        Set_Font shp, font   ' else change font
    End If
End Sub

The 'Set_Font(shp as Shape, font as String)' subroutine is just to avoid redundancy. It simply checks if the given shp has text with any other font than font and changes it. At some place, Set_Font_Of_All_TextFrames Nothing "X" is called. It works as expected, but the following questions arise:

1) How can I make this functionality available for other operations than changing fonts? Do I really have to copy-paste all this?

2) Can I use a function to walk through all shapes and groups like in my function but instead of calling the set_font subroutine, it populates a list with references to all shapes it can find? This list I can pass to the e.g. set_font subroutine (and any other which should perform an action on all shapes)?

3) Why are shapes on the master excluded from my function?

Upvotes: 0

Views: 688

Answers (1)

LCsa
LCsa

Reputation: 657

Thanks to the comments I discovered that this is more or less the way to go. I post here my "ulitity function" to produce a collection of all shapes (including all shapes in arbitrarily nested subgroups) that can be used and iterated through in any other function or subroutine.

Simple version that goes through all slides in the active presentation (it also clearly show how the function is supposed to operate):

Function Get_All_Shapes(oShp As Shape, oColl As Collection)
' Go through all shapes on all slides. This is a recursive function. First call needs to pass "Nothing" to oShp and oColl.
' The collection oColl will be populated with all shapes (including all shapes in all groups) in the presentation.
' The return parameter will be the gradually populated collection.
' The recursion is necessary in order to go through groups.

    Dim sld As Slide
    Dim shp As Shape
    Dim i As Integer

    If oShp Is Nothing And oColl Is Nothing Then ' first function call
        Set oColl = New Collection
        For Each sld In ActivePresentation.Slides
            For Each shp In sld.Shapes
                If shp.Type = msoGroup Then
                    Set oColl = Get_All_Shapes(shp, oColl)  ' recursive call in case of group
                Else
                    oColl.Add shp ' else add shape to collection
                End If
            Next shp
        Next sld
    ' in case of recursive calls:
    ElseIf oShp.Type = msoGroup Then
        For i = 1 To oShp.GroupItems.Count()
            Set shp = oShp.GroupItems.Item(i)
            Set oColl = Get_All_Shapes(shp, oColl) ' another recursive call in case of group; will repeat this branch in case of subgroup
        Next
    Else
        oColl.Add oShp ' else add shape to collection
    End If
    Set Get_All_Shapes = oColl ' set populated collection as function return parameter
End Function

Here is a more refined version that lets you choose whether to populate the collection with only selected shapes (and nested subgroups) and if the master slide with its custom layouts should be included into the collection:

Function Get_All_Shapes_WIP(oShp As Shape, oColl As Collection, Optional onlySelected As Boolean = False, Optional includeMaster As Boolean = False)
' Go through all shapes on all slides. This is a recursive function. First call needs to pass "Nothing" to oShp and oColl.
' The collection oColl will be populated with all shapes (including all shapes in all groups) in the presentation.
' The return parameter will be the gradually populated collection.
' The recursion is necessary in order to go through groups.
' If onlySelected is True, only the selected shapes will be added to the collection.
' If includeMaster is True, shapes on the master slide and all custom layouts will be added to the collection. This behavior is not affected by the value of onlySelected.

    Dim sld As Slide
    Dim shp As Shape
    Dim i As Integer

    ' first function call (main loops)
    If oShp Is Nothing And oColl Is Nothing Then
        Set oColl = New Collection

        ' presentation loops
        If onlySelected = False Then ' all shapes on all slides
            For Each sld In ActivePresentation.Slides
                For Each shp In sld.Shapes
                    If shp.Type = msoGroup Then
                        Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
                    Else
                        oColl.Add shp ' else add shape to collection
                    End If
                Next shp
            Next sld

        Else ' onlySelected = True
            For Each shp In ActiveWindow.selection.ShapeRange
                If shp.Type = msoGroup Then
                    Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
                Else
                    oColl.Add shp ' else add shape to collection
                End If
            Next shp
        End If

        ' master loops
        If includeMaster = True Then ' add also slide master shapes to the collection
            ' master shapes
            For Each shp In ActivePresentation.SlideMaster.Shapes
                If shp.Type = msoGroup Then
                    Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
                Else
                    oColl.Add shp ' else add shape to collection
                End If
            Next shp
            ' custom layouts shapes
            For i = 1 To ActivePresentation.SlideMaster.CustomLayouts.Count()
                For Each shp In ActivePresentation.SlideMaster.CustomLayouts.Item(i).Shapes
                If shp.Type = msoGroup Then
                    Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' recursive call in case of group
                Else
                    oColl.Add shp ' else add shape to collection
                End If
                Next shp
            Next
        End If

    ' recursive calls:
    ElseIf oShp.Type = msoGroup Then
        For i = 1 To oShp.GroupItems.Count()
            Set shp = oShp.GroupItems.Item(i)
            Set oColl = Get_All_Shapes_WIP(shp, oColl, onlySelected, includeMaster) ' another recursive call in case of group; will repeat this branch in case of subgroup
        Next
    Else
        oColl.Add oShp ' else add shape to collection
    End If

    Set Get_All_Shapes_WIP = oColl ' set (partially) populated collection as function return parameter in every call
End Function

Example of usage:

Sub Set_All_Fonts_To_Calibri()
' Sets the font of all text in all shapes in the presentation to "Calibri".

    Dim coll As Collection: Set coll = Get_All_Shapes_WIP(Nothing, Nothing, onlySelected:=False, includeMaster:=True)
    Dim shp As Shape

    For Each shp In coll
        Set_Font shp, "Calibri"
    Next shp
End Sub

Upvotes: 3

Related Questions