balumail75
12-21-2010, 05:52 AM
Hi all,
I tried for saving ppt files as jpg with the below code, by looping through a folder. It creates folders and saving it as Slide1.jpg in each folder. Please help me to save as with the same name.jpg.
Below is the code:
Sub Tojpg()
Dim oApp As Object
Dim ofolder
Dim rpath As String
Dim pptOpen As Presentation
Dim strExtension As String
Dim fname As String
Dim flname As String
Dim fpname As String
Dim fpathandname As String
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set ofolder = oApp.BrowseForFolder(0, "Select folder", 512)
If ofolder Is Nothing Then
MsgBox "Good-bye! Better Try Next Time!"
Exit Sub
End If
rpath = ofolder.self.Path
On Error Resume Next
ChDir rpath
strExtension = Dir("*.pptx")
Do While strExtension <> ""
Set pptOpen = Presentations.Open(strExtension)
With pptOpen
fpname = ActivePresentation.Path & "\"
fname = ActivePresentation.Name
flname = Left(fname, 10) & ".jpg"
fpathandname = fpname & flname
'ActivePresentation.SaveAs FileName:=fname, FileFormat:=ppSaveAsJPG
ActivePresentation.SaveAs FileName:=fpathname, FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoTrue
'ActivePresentation.Slides(1).Export fpname & "\" & flname & ".jpg", "JPG"
Application.ActivePresentation.Close
End With
strExtension = Dir
Loop
On Error GoTo 0
End Sub
I tried for saving ppt files as jpg with the below code, by looping through a folder. It creates folders and saving it as Slide1.jpg in each folder. Please help me to save as with the same name.jpg.
Below is the code:
Sub Tojpg()
Dim oApp As Object
Dim ofolder
Dim rpath As String
Dim pptOpen As Presentation
Dim strExtension As String
Dim fname As String
Dim flname As String
Dim fpname As String
Dim fpathandname As String
Set oApp = CreateObject("Shell.Application")
'Browse to the folder
Set ofolder = oApp.BrowseForFolder(0, "Select folder", 512)
If ofolder Is Nothing Then
MsgBox "Good-bye! Better Try Next Time!"
Exit Sub
End If
rpath = ofolder.self.Path
On Error Resume Next
ChDir rpath
strExtension = Dir("*.pptx")
Do While strExtension <> ""
Set pptOpen = Presentations.Open(strExtension)
With pptOpen
fpname = ActivePresentation.Path & "\"
fname = ActivePresentation.Name
flname = Left(fname, 10) & ".jpg"
fpathandname = fpname & flname
'ActivePresentation.SaveAs FileName:=fname, FileFormat:=ppSaveAsJPG
ActivePresentation.SaveAs FileName:=fpathname, FileFormat:=ppSaveAsJPG, EmbedTrueTypeFonts:=msoTrue
'ActivePresentation.Slides(1).Export fpname & "\" & flname & ".jpg", "JPG"
Application.ActivePresentation.Close
End With
strExtension = Dir
Loop
On Error GoTo 0
End Sub