Auto format similar shapes in Power Point

Below method allows you to remove the shadow from all shapes of the same type (arrow, rectangle, ... ) at once, instead of selecting each shape manually.

If you want to apply more formats than only removing a shadow, then use the methods PickUp and Apply of the Shape object.

PickUp copies the format of one Shape object and Apply copies a before picked up format.

Source Code 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
' @Author - Alexander Bolte
' @ChangeDate - 2014-11-27
' @Description - removing a shadow from all objects of type Shape 
' of the same type (arrow, rectangle, ...) in current slides.
' Select one shape e.g. an arrow in a power point presentation and execute this code.
' The method iterates through all shapes in current ShapeRange and removes the 
' shadow style from all shapes of the same type.
Sub PickItUp()
    Dim oSld As Slide
    Dim oSelShp As Shape
    Dim oShp As Shape
    Dim lType As Long
 
    On Error GoTo err_handle:
 
    ' Results are unpredictable if you start with
    ' more than one shape selected.
    If ActiveWindow.Selection.ShapeRange.Count <> 1 Then
        MsgBox "Select only one shape", vbExclamation, "Power Point"
	Exit Sub
    End If
 
    ' set a reference to the selected shape
    Set oSelShp = ActiveWindow.Selection.ShapeRange(1)
 
    With oSelShp
        ' pick up its formatting
        .PickUp
        ' store its type
        lType = .Type
 
        ' Exclude placeholders
        If lType = 14 Then
            Exit Sub
        End If
 
        If .Fill.Type = msoFillPicture Then
            Exit Sub
        End If
 
        For Each oSld In ActivePresentation.Slides
            For Each oShp In oSld.Shapes
                If oShp.Type = lType Then
                    If oShp.Fill.Type <> msoFillPicture Then
                        'oShp.Apply
                        oShp.Shadow.Visible = msoFalse
                    End If  ' <> msoFillPicture
                End If  ' Type - lType
            Next oShp
        Next oSld
    End With    ' oSelShp
 
err_handle:
    If Err.Number <> 0 Then
        Err.Clear
    End If
    MsgBox "Uncatched exception.", vbCritical, "Power Point"
End Sub
Hits: 9969