Batch-Video-Export in Powerpoint

[shirter]

Hello,

I have to export video files from my powerpoint-presentations regularlyand I am using PP 2016. Since that tooks a lot of time, it would be great to have a batch-script which could export videos from several Powerpoint-Presentations overnight. Videos should be in Full-HD (1080p) and the single slides should use the recorded slide time.

Is it possible to do this in VBA? I have found some scripts for the export settings, but none for a batch-use.

Thanks for your reply,

regards

Jenson

[leemis]

did you find a solution for this by any chance? i am new to vb and powerpoint. i came across all the same stuff online you probably came across. i am trying to figure out the best way to export each slide as an individual video. i can export as a single video using a macro and i can export individual ppt files using a macro but can't seem to connect the two into a macro that will give me an individual video for each slide in a presentation.

if anyone can point me in a direction, i would appreciate it.

[John Wilson]

This should (not tested) export a batch of videos from ppt files in a folder on the desktop names "Files"


Sub BatchVid2()

Dim rayFileList() As String
Dim FolderPath As String
Dim FileSpec
Dim strTemp As String
Dim x As Long
Dim saveName As String
Dim PresName As String
Dim opres As Presentation



FolderPath = Environ("USERPROFILE") & "\Desktop\Files\"
FileSpec = "*.ppt*"



' Fill the array with files that meet the spec above
ReDim rayFileList(1 To 1) As String
strTemp = Dir$(FolderPath & FileSpec)
While strTemp <> ""
rayFileList(UBound(rayFileList)) = FolderPath & strTemp
ReDim Preserve rayFileList(1 To UBound(rayFileList) + 1) As String
strTemp = Dir
Wend
If UBound(rayFileList) > 1 Then
ReDim Preserve rayFileList(1 To UBound(rayFileList) - 1)




For x = 1 To UBound(rayFileList)
Call Presentations.Open(rayFileList(x), False, False, True)
Next x
End If
For x = 1 To UBound(rayFileList)
PresName = Mid(rayFileList(x), InStrRev(rayFileList(x), "\") + 1)
saveName = Left(PresName, InStrRev(PresName, ".") - 1)
Presentations(PresName).CreateVideo FileName:=FolderPath & saveName & ".mp4", _
UseTimingsAndNarrations:=True, _
VertResolution:=1080, _
FramesPerSecond:=25, _
Quality:=100
Next x


End Sub




There is no built in way to export a single slide to a video you would need to save a copy and delete unwanted slides.

[leemis]

This was more than helpful! Thank you!

It worked great and I was able to understand it (sort of) enough to add my other bits to it. Now to figure out how to zip up my results as a single zip. :)

[leemis]

one thing i tried to figure out was how to close all the windows when it was complete. i can close all the windows using a msgbox but have not figured out how to close it after each progress status was complete. Is there way to poll all the active open windows to know when it is complete? ppMediaTaskStatus.ppMediaTaskStatusDone doesn't seem to catch the event when it is done.

[leemis]

one thing i tried to figure out was how to close all the windows when it was complete.

I figured it out. Was looping through the wrong names. Thanks again for all the help!

[John Wilson]

Yep, I deliberately left the windows open because in code the window can close too early before the video is quite complete. It only takes a second to manually close them! Glad it worked though

[leemis]

Would you know if it is possible to take all the files (the videos, images, text files, etc) that i am exporting from this and zip it into a single file from within PPT? I need to take a folder full of files and zip them from within PPT. What I have found seems to be for xls and it uses the FileSystemObject which throws errors I don't really understand just yet other than it seems to not support it.

Seems like I might be able to create a batch file that can do this but I need to do this from PPT if possible.

[John Wilson]

This (based on Ron De Bruin's code) should zip everything in a folder. You would want to be sure the videos were NOT saved to the same folder as the original Powerpoint files.


Sub NewZip(sPath)'Create empty Zip File
Dim filenum As Integer
filenum = FreeFile
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #filenum
Print #filenum, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #filenum
End Sub
Sub Zip_All_Files_in_Folder()
Dim FileNameZip, FolderName
Dim DefPath As String
Dim oApp As Object


DefPath = Environ("USERPROFILE") & "\Desktop\"
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If


FolderName = Environ("USERPROFILE") & "\Desktop\test\" '<< Change


FileNameZip = DefPath & "FilesZip" & ".zip"


'Create empty Zip File
NewZip (FileNameZip)


Set oApp = CreateObject("Shell.Application")
'Copy the files to the compressed folder
oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items


MsgBox "You find the zipfile here: " & FileNameZip
End Sub