Open all PowerPoints in a folder and update font and text

[TaskMaster]

Hi all,

We have been instructed to update all of our documents to standardise the format, of which I have about 100 PowerPoints which I would have to change the font and text colour and wondering if there is a way to automate this via some vba, my thinking would be to select the folder location and then pick up all the pptx in that location. Is anyone able to help with this?

 

[TaskMaster]

If anyone else needs it found the following solution.

Sub UpdatePowerPointPresentations()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim pptShape As Object
    Dim pptTextRange As Object
    Dim pptFolder As String
    Dim pptFile As String
    Dim NewFileName As String
    Dim fd As FileDialog
    Dim FontName As String
    Dim FontColor As Long
    
    ' Set the font name and color you want to use
    FontName = "Arial"
    FontColor = RGB(255, 0, 0) ' Red color
    
    ' Create FileDialog to select folder
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "Select Folder Containing PowerPoint Files"
        If .Show = -1 Then
            pptFolder = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    ' Create PowerPoint application object
    On Error Resume Next
    Set pptApp = CreateObject("PowerPoint.Application")
    On Error GoTo 0
    If pptApp Is Nothing Then
        MsgBox "PowerPoint is not installed or not available."
        Exit Sub
    End If
    
    pptApp.Visible = True
    
    ' Loop through all PowerPoint files in the folder
    pptFile = Dir(pptFolder & "*.ppt*")
    Do While pptFile <> ""
        Set pptPres = pptApp.Presentations.Open(pptFolder & pptFile, WithWindow:=msoFalse)
        
        ' Loop through each slide in the presentation
        For Each pptSlide In pptPres.Slides
            ' Loop through each shape in the slide
            For Each pptShape In pptSlide.Shapes
                ' Check if the shape has text
                If pptShape.HasTextFrame Then
                    If pptShape.TextFrame.HasText Then
                        Set pptTextRange = pptShape.TextFrame.TextRange
                        pptTextRange.Font.Name = FontName
                        pptTextRange.Font.Color.RGB = FontColor
                    End If
                End If
            Next pptShape
        Next pptSlide
        
        ' Save the presentation with "updated" appended to the file name
        NewFileName = pptFolder & Left(pptFile, InStrRev(pptFile, ".") - 1) & " updated" & Mid(pptFile, InStrRev(pptFile, "."))
        pptPres.SaveAs NewFileName
        pptPres.Close
        
        ' Get the next PowerPoint file
        pptFile = Dir
    Loop
    
    pptApp.Quit
    Set pptApp = Nothing
    
    MsgBox "All PowerPoint presentations have been updated and saved."
End Sub