Useful PowerPoint Macro Examples

Useful PowerPoint Macro Examples

Here are some useful macro examples showing how to do tasks. These will also demonstrate the concepts described above.

Change Slide During Slide Show

Sub ChangeSlideDuringSlideShow()
    Dim SlideIndex As Integer
    Dim SlideIndexPrevious As Integer
 
    '  Change Current slide to selected slide 4 during during slide show
    SlideIndex = 4
    ' Index of the current slide show window is 1 in the SlideShowWindows collection
    SlideIndexPrevious = SlideShowWindows(1).View.CurrentShowPosition
    SlideShowWindows(1).View.GotoSlide SlideIndex
     
End Sub

Change Font on All Slides in All TextBoxes

Sub ChangeFontOnAllSlides()
    Dim mySlide As slide
    Dim shp As Shape
    
    ' Change Font Size on all Slides
    For Each mySlide In ActivePresentation.Slides
      For Each shp In mySlide.Shapes
        If shp.Type = 17 Then ' msoTextBox = 17
          ' Change Fontsize to 24
          shp.TextFrame.TextRange.Font.Size = 24
        End If
      Next shp
    Next mySlide
 
End Sub

Change Case From Upper to Normal in All TextBoxes

Sub ChangeCaseFromUppertoNormal()
    Dim mySlide As slide
    Dim shp As Shape
    
    ' Change From Upper Case to Normal Case for all slides
    For Each mySlide In ActivePresentation.Slides
      For Each shp In mySlide.Shapes
        If shp.Type = 17 Then ' msoTextBox = 17
          ' Change Upper Case to Normal Case
          shp.TextFrame2.TextRange.Font.Allcaps = False
        End If
      Next shp
    Next mySlide
 
End Sub

Toggle Case between Upper and Normal in All TextBoxes

Sub ToggleCaseBetweenUpperAndNormal()
    Dim mySlide As slide
    Dim shp As Shape
 
    '  Toggle between Upper Case and Normal Case for all slides
    For Each mySlide In ActivePresentation.Slides
      For Each shp In mySlide.Shapes
        If shp.Type = 17 Then ' msoTextBox = 17
          ' Toggle between Upper Case and Normal Case
          shp.TextFrame2.TextRange.Font.Allcaps = _
            Not shp.TextFrame2.TextRange.Font.Allcaps
        End If
      Next shp
    Next mySlide
 
End Sub

Remove Underline from Descenders

In typography, a descender is the portion of a letter that extends below the baseline of a font. In most fonts, descenders are reserved for lowercase characters such as g, j, q, p, y, and sometimes f.

When you underline text, it does not look nice under descenders. Here is the code to remove underline from all such characters g, j, p, q, and y in the whole Presentation.

Sub RemoveUnderlineFromDescenders()
    Dim mySlide As slide
    Dim shp As Shape
    Dim descenders_list As String
    Dim phrase As String
    Dim x As Long
    
    ' Remove underlines from Descenders
    descenders_list = "gjpqy"
    For Each mySlide In ActivePresentation.Slides
      For Each shp In mySlide.Shapes
        If shp.Type = 17 Then ' msoTextBox = 17
         ' Remove underline from letters "gjpqy"
         With shp.TextFrame.TextRange
            phrase = .Text
           For x = 1 To Len(.Text)
             If InStr(descenders_list, Mid$(phrase, x, 1)) > 0 Then
              .Characters(x, 1).Font.Underline = False
             End If
           Next x
         End With
       End If
      Next shp
    Next mySlide
 
End Sub

Remove Animations From All Slides

Use the code below to remove all animations set in a Presentation.

Sub RemoveAnimationsFromAllSlides()
    Dim mySlide As slide
    Dim i As Long
 
    For Each mySlide In ActivePresentation.Slides
      For i = mySlide.TimeLine.MainSequence.Count To 1 Step -1
       'Remove Each Animation
       mySlide.TimeLine.MainSequence.Item(i).Delete
      Next i
    Next mySlide
     
End Sub

Save Presentation As PDF

You can easily save Active Presentation in PDF format.

Sub SavePresentationAsPDF()
    Dim pptName As String
    Dim PDFName As String
    
    ' Save PowerPoint as PDF
    pptName = ActivePresentation.FullName
    ' Replace PowerPoint file extension in the name to PDF
    PDFName = Left(pptName, InStr(pptName, ".")) & "pdf"
    ActivePresentation.ExportAsFixedFormat PDFName, 2  ' ppFixedFormatTypePDF = 2
 
End Sub

Find and Replace Text

You can find and replace text in All TextBoxes of All Slides. After the fist instance of the text you want to find (defined by findWhat) you need to loop through the Find command to find other instances, if any.

Sub FindAndReplaceText()
    Dim mySlide As slide
    Dim shp As Shape
    Dim findWhat As String
    Dim replaceWith As String
    Dim ShpTxt As TextRange
    Dim TmpTxt As TextRange

    findWhat = "jackal"
    replaceWith = "fox"
     
    ' Find and Find and Replace
    For Each mySlide In ActivePresentation.Slides
      For Each shp In mySlide.Shapes
        If shp.Type = 17 Then ' msoTextBox = 17
          Set ShpTxt = shp.TextFrame.TextRange
          'Find First Instance of "Find" word (if exists)
          Set TmpTxt = ShpTxt.Replace(findWhat, _
             Replacewhat:=replaceWith, _
             WholeWords:=True)
     
          'Find Any Additional instances of "Find" word (if exists)
          Do While Not TmpTxt Is Nothing
            Set ShpTxt = ShpTxt.Characters(TmpTxt.Start + TmpTxt.Length, ShpTxt.Length)
            Set TmpTxt = ShpTxt.Replace(findWhat, _
              Replacewhat:=replaceWith, _
              WholeWords:=True)
          Loop
        End If
      Next shp
    Next mySlide
 
End Sub

Export Slide As Image

You can export Current SLide (or any other slide) as a PNG or JPG (JPEG) or BMP image.

Sub ExportSlideAsImage()
    Dim imageType As String
    Dim pptName As String
    Dim imageName As String
    Dim mySlide As slide
    
    ' Export current Slide to Image
    imageType = "png" ' or jpg or bmp
    pptName = ActivePresentation.FullName
    imageName = Left(pptName, InStr(pptName, ".")) & imageType
    Set mySlide = Application.ActiveWindow.View.slide
    mySlide.Export imageName, imageType
 
End Sub

Resize Image To Cover Full Slide

Sub ResizeImageToCoverFullSlide()
    Dim mySlide As slide
    Dim shp As Shape
    
 
    ' Resize Image to full slide size
    ' Change height and width of the first shape on the current slide
    ' to fit the slide dimensions
    Set mySlide = Application.ActiveWindow.View.slide
    Set shp = mySlide.Shapes(1)
    ''
    '' Replace two statemetns above with
    '' the following statement if you want to
    '' expand the currently selected shape
    '' will give error if nothing is selected
    'Set shp = ActiveWindow.Selection.ShapeRange(1)
     
    With shp
        .LockAspectRatio = False
        .Height = ActivePresentation.PageSetup.SlideHeight
        .Width = ActivePresentation.PageSetup.SlideWidth
        .Left = 0
        .Top = 0
    End With
 
End Sub

Exit All Running Slide Shows

If you have multiple Slide Shows open at the same time then you can close all of them using the macro below.

Sub ExitAllRunningSlideShows()
 
    Do While SlideShowWindows.Count > 0
        SlideShowWindows(1).View.Exit
    Loop
 
End Sub