CODEWITHSUNDEEP
vbaloopspowerpoint
Simon
Simon

Reputation: 63

Powerpoint VBA loop through all presentations in folder

so my problem is this: I want to change the color of a text shape in more than 250 presentations (files). I can do this if the presentations are active and open by doing this:

Sub ChangeShapeColor()
    Dim oSh As Shape
    Dim oSl As Slide
    Dim prs As Presentation

    For Each prs In Presentations

        For Each oSl In ActivePresentation.Slides

            For Each oSh In oSl.Shapes

                If oSh.Fill.ForeColor.RGB = RGB(84, 133, 192) Then
                oSh.Fill.ForeColor.RGB = RGB(0, 51, 204)
                oSh.Fill.Transparency = 0.4
                End If

                If oSh.Fill.ForeColor.RGB = RGB(202, 24, 24) Then
                oSh.Fill.ForeColor.RGB = RGB(212, 10, 10)
                oSh.Fill.Transparency = 0.4
                End If

            Next oSh
        Next oSl
    Next prs
End Sub

However all the files are stored in one folder and then many more subfolders.

How do I have to adjust the code, that the vba opens within a loop step by step all the other presentations in a specific folder C://xyz/xyx/presentations, executes the sub and saves it?

Thanks in advance

Upvotes: 1

Views: 3470

Answers (1)

Steve Rindsberg
Steve Rindsberg

Reputation: 14810

Change the sub to:

Sub ChangeShapeColor(oPres as Presentation)

Dim oSh As Shape
Dim oSl As Slide

For Each oSl In oPres.Slides

    For Each oSh In oSl.Shapes

        If oSh.Fill.ForeColor.RGB = RGB(84, 133, 192) Then
        oSh.Fill.ForeColor.RGB = RGB(0, 51, 204)
        oSh.Fill.Transparency = 0.4
        End If

        If oSh.Fill.ForeColor.RGB = RGB(202, 24, 24) Then
        oSh.Fill.ForeColor.RGB = RGB(212, 10, 10)
        oSh.Fill.Transparency = 0.4
        End If

    Next oSh
Next oSl

End Sub

Then write a routine that iterates through your chosen subdirectory and all subdirs off that, and for each presentation found, 

Set oPres = Presentations.Open(path_to_presentation_file)
Call ChangeShapeColor(oPres)
oPres.Close

Tell Google: vba list files in directory and subdirectories That should get you any number of routines to get the file listings.

One way to do this is with the Dir function in a loop. This does not scan sub-folders, you'll need a different approach for that.

path = ""
filename = Dir(path)   'Get the first file
While filename <> ""
    'Avoid errors if the file cannot be opened by PPT, i.e., it is a DOCX or some other format
    On Error Resume Next
    filename = path & filename
    Set oPres = Presentations.Open(filename, WithWindow:=False)
    If Err.Number <> 0 Then
        Debug.Print "Unable to open " & filename
    End If
    On Error GoTo 0  ' Resume normal error handling
    Call ChangeShapeColor(oPres)
    oPres.Close
    filename = Dir()  'Get the next file in the folder
Wend

Upvotes: 5

Related Questions