Compress media

OfficeTips Home || VBA Section || General Section || Download Section || Privacy Policy

Compress media

The MediaFormat object has two properties Resample and ResampleFromProfile which does this. More about the MediaObject here: http://skp.mvps.org/2010/ppt002.htm

Resample method allows custom settings to be applied to resample media.
Sub Resample([Trim As Boolean = False], [SampleHeight As Long = 768], [SampleWidth As Long = 1280], [VideoFrameRate As Long = 24], [AudioSamplingRate As Long = 48000], [VideoBitRate As Long = 7000000])

ResampleFromProfile is a little known method that allows you tap into the UI profile settings that are in the File | Info | Compress Media options specific to a shape.
Sub ResampleFromProfile([profile As PpResampleMediaProfile = ppResampleMediaProfileSmall])

When the resample begins, you will see the progress bar appearing on the status bar. If the presentation has never been saved to disk, resample will begin when the presentation is saved.

Supported versions: PowerPoint 2013 or later

' --------------------------------------------------------------------------------

' Copyright ©1999-2022, Shyam Pillai, All Rights Reserved.

' --------------------------------------------------------------------------------

' You are free to use this code within your own applications, add-ins,

' documents etc but you are expressly forbidden from selling or

' otherwise distributing this source code without prior consent.

' This includes both posting free demo projects made from this

' code as well as reproducing the code in text or html format.

' --------------------------------------------------------------------------------

Sub Resample()

Dim oShp As Shape



' Assumes that this shape is either inserted video or audio.

Set oShp = ActiveWindow.Selection.ShapeRange(1)



' Note: Online video is also flagged as mediatype shape

' but it fails on all these properties, only SourceFullName property works



If oShp.Type = msoMedia Then

    oShp.MediaFormat.ResampleFromProfile (ppResampleMediaProfileSmallest)

End If

End Sub