set duration and resolution (for each slide) in ppt video (using vba code )

[syed_iqbal]

HI,



i wrote a ppt code which is covert ppt to mp4. it is working. but i want to set timing (each slide 13 seconds) & resolution (1280 X720) for each slide by using code. Pls help.

Option Explicit


Sub GetFolderPath()
Dim InputFolder As String
Dim OutputFolder As String
Dim fd1, fd2 As FileDialog
Dim cpath, dpath As String
Dim FileInFromFolder As Object
Dim fil As Scripting.File
Dim cfolder, dfolder As Scripting.Folder
'-----------------------------------------------------------------------------------------
Dim fso As Scripting.filesystemobject
Dim actionclicked As Boolean
Set fso = New Scripting.filesystemobject
Set fd1 = Application.FileDialog(msoFileDialogFolderPicker)
Set fd2 = Application.FileDialog(msoFileDialogFolderPicker)


fd1.Title = "pick the folder to save files into"
fd1.AllowMultiSelect = False
actionclicked = fd1.Show
If actionclicked Then
InputFolder = fd1.SelectedItems(1)
Else
MsgBox "You didn't pick a folder"
Exit Sub
End If
If InputFolder = "" Then
MsgBox "Select a folder then click Yes"
Exit Sub
End If
cpath = InputFolder


Set fso = New Scripting.filesystemobject


Set cfolder = fso.GetFolder(cpath)
cpath = Replace(cpath, "\\", "\")
Debug.Print cfolder




Set fd2 = Application.FileDialog(msoFileDialogFolderPicker)
fd2.Title = "pick the folder to save files into"
fd2.AllowMultiSelect = False
actionclicked = fd2.Show
If actionclicked Then
OutputFolder = fd2.SelectedItems(1)
Else
MsgBox "You didn't pick a folder"
Exit Sub
End If
If OutputFolder = "" Then
MsgBox "Select a folder then click Yes"
Exit Sub
End If
dpath = OutputFolder




Set fso = New Scripting.filesystemobject


Set dfolder = fso.GetFolder(dpath)
dpath = Replace(dpath, "\\", "\")




'Debug.Print dfolder
For Each fil In cfolder.Files


If Left(fso.GetExtensionName(fil.Path), 2) = "pp" And Format(fil.DateLastModified, "dd/mm/yyyy") = Format(Date, "dd/mm/yyyy") Then
Application.ActivePresentation.SaveAs _
FileName:=dpath & "\" & fil.Name & ".mp4", _
FileFormat:=ppSaveAsMP4

End If

Next


thank you in advance.


End Sub