I need to generate for each slide of my presentation a pdf file.
I'm using the following code:
ActivePresentation.ExportAsFixedFormat ActivePresentation.Path & "\" & ActivePresentation.Name & ".pdf", ppFixedFormatTypePDF, ppFixedFormatIntentPrint
This code works fine, but it exports all the slides into a unique pdf file.
You can do that:
Below code will create pdf with adding the slide number at end of current folder, file name.
Sub ExportSlidesToIndividualPDF()
Dim oPPT As Presentation, oSlide As Slide
Dim sPath As String, sExt As String
Set oPPT = ActivePresentation
sPath = oPPT.FullName & "_Slide_"
sExt = ".pdf"
For Each oSlide In oPPT.Slides
i = oSlide.SlideNumber
oSlide.Select
oPPT.ExportAsFixedFormat _
Path:=sPath & i & sExt, _
FixedFormatType:=ppFixedFormatTypePDF, _
RangeType:=ppPrintSelection
Next
Set oPPT = Nothing
End Sub
For me, the the accepted answer doesn't work. Also tried the fix suggested in the comment. Probably because I'm on Mac or sth.
I found this alternative question/answer which I tweaked to save each slide separately:
Sub each_slide_to_separate_pdf()
'Hide all slides
For i = 1 To ActivePresentation.Slides.Count
ActivePresentation.Slides(i).SlideShowTransition.Hidden = msoTrue
Next i
'display each slide and save
For i = 1 To ActivePresentation.Slides.Count
'display current slide
ActivePresentation.Slides(i).SlideShowTransition.Hidden = msoFalse
'Save location
Dim filePath As String
filePath = "/Users/username/Documents/vba_folder" & i & "slide.pdf"
ActivePresentation.SaveAs filePath, ppSaveAsPDF
'hide the just saved slide
ActivePresentation.Slides(i).SlideShowTransition.Hidden = msoTrue
Next i
'Show all slides again
For i = 1 To ActivePresentation.Slides.Count
ActivePresentation.Slides(i).SlideShowTransition.Hidden = msoFalse
Next i
End Sub
Sub ExportSlidesToIndividualPDF()
Dim oPPT As Presentation, oSlide As Slide
Dim sPath As String, sExt As String
Dim dlgOpen As FileDialog
Set oPPT = ActivePresentation
timestamp = Now()
sExt = ".pdf"
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then ' if OK is pressed
sPath = .SelectedItems(1)
With dlgOpen
For Each oSlide In oPPT.Slides
i = oSlide.SlideNumber
oSlide.Select
oPPT.ExportAsFixedFormat _
Path:=sPath & "\" & Format(timestamp, "yyyymmdd") & "_" & "Slide#" & i & sExt, _
FixedFormatType:=ppFixedFormatTypePDF, _
RangeType:=ppPrintSelection
Next
End With
End If
End With
Set oPPT = Nothing
End Sub
I added an OpenFileDialogPicker, so you can choose the wishen location by yourself
I discovered a fast / easy way to save individual slides in a ppt presentation as separate pdf files...nothing fancy...just a few steps...
(1) right-click on the slide (as it appears in the left-hand column), select COPY
(2) Left-Click on your bottom left Start button and open the PowerPoint program anew to a blank page
(3) Right-Click in that blank doc and hit Paste (you may have an extra blank page at the top, just right-click and Cut it to get rid of it)
(4) File / Save As / (select) PDF
REPEAT the steps for each slide
Related
See code below does work as a PPTX currently.
I need to have this export as a PDF not a PPTX and am having no luck. Help much appreciated! Also having no luck adding an email signature automatically to this code. Granted many users will end up using this macro.
Sub EmailFinal()
Dim objActivePresetation As Presentation
Dim objSlide As Slide
Dim n As Long
Dim strName As String
Dim strTempPresetation As String
Dim objTempPresetation As Presentation
Dim objOutlookApp As Object
Dim objMail As Object
Set objActivePresetation = ActivePresentation
For Each objSlide In objActivePresetation.Slides
objSlide.Tags.Delete ("Selected")
Next
'Add a tag "Selected" to the selected slides
For n = 1 To ActiveWindow.Selection.SlideRange.Count
ActiveWindow.Selection.SlideRange(n).Tags.Add "Selected", "YES"
Next n
strName = objActivePresetation.Name
strName = Left(strName, InStrRev(strName, ".") - 1)
strTempPresetation = Environ("TEMP") & "\" & strName & ".pptx"
'Copy the active presentation to a temp presentation
objActivePresetation.SaveCopyAs strTempPresetation
Set objTempPresetation = Presentations.Open(strTempPresetation)
'Remove the untagged slides
For n = objTempPresetation.Slides.Count To 1 Step -1
If objTempPresetation.Slides(n).Tags("Selected") <> "YES" Then
objTempPresetation.Slides(n).Delete
End If
Next n
objTempPresetation.Save
objTempPresetation.Close
'Attach the temp presentation to a new email
Set objOutlookApp = CreateObject("Outlook.Application")
Set objMail = objOutlookApp.CreateItem(olMailItem)
'Change the email details as per your needs
With objMail
.To = "insertemailhere"
.Subject = strName
.Body = "Dear Company," & vbCr & vbCr & "Please see attached Plaques.," & vbCr & "Please let me know if you need any further assistance."
.Attachments.Add strTempPresetation
.Display
End With
End Sub
Thank You!!
Use the Presentation.ExportAsFixedFormat method.
Instead of objTempPresetation.Save do objTempPresetation.ExportAsFixedFormat and specify your desired parameters but at least specify those parameters:
objTempPresetation.ExportAsFixedFormat Path:="C:\yourpath\yourfile.pdf", FixedFormatType:=ppFixedFormatTypePDF
other parameters are optional.
I'm trying to write a batch find and replace code for Power Point slides in VBA but I'm getting the following error: Compile Error Method or data member not found.
The debugger is highlighting Shapes in PP.Shapes on line 13.
I do not have much experience with VBA. I gathered ideas from:
* Getting Started with VBA in PowerPoint 2010 (Office Dev Center)
* Power Point VBA-Find & Replace (YouTube)
* "Simple Macro to import slides from a file" # (VBA Express Forum)
Sub BatchFindReplace()
Dim shp As Shape
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
'Directory
strFolderName = "C:\Users\Emma\Desktop\temp1"
strFileName = Dir(strFolderName & "\*.ppt*")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'Find and Replace Code
For Each shp In PP.Shapes
If shp.HasTextFrame Then
If shp.TextFrame.HasText Then
shp.TextFrame.TextRange.Text = Replace(shp.TextFrame.TextRange.Text, "W", "kkk")
End If
End If
Next
PP.Close
strFileName = Dir
Loop
End Sub
The property .Shapes is not a member of Presentation but of Slide
'~~> Open the relevant powerpoint file
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
'~~> Change this to the relevant slide which has the shape
Set PPSlide = PP.Slides(1)
For Each shp In PPSlide.Shapes
Debug.Print shp.Name
Next shp
If you want to work with all shapes in all slides then you will have to loop through slides.
Dim sld As Slide
'~~> Open the relevant powerpoint file
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
For Each sld In PP.Slides
For Each shp In sld.Shapes
Debug.Print shp.Name
Next shp
Next
I have a macro to export the current page without any formulas or code. There are a few problems.
Sub ExportXLSX()
Application.EnableEvents = False
Dim MyPath As String
Dim MyFileName As String
MyFileName = Sheets("Order Summary").Range("B2").Value & "_" & Format(Date, "yyyymmdd")
If Not Right(MyFileName, 4) = ".xlsx" Then MyFileName = MyFileName & ".xlsx"
Sheets("Order Summary").Copy
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select where you want to save"
.AllowMultiSelect = False
.InitialFileName = "" 'Start folder path for the file picker.
If .Show <> -1 Then GoTo NextCode
MyPath = .SelectedItems(1) & "\"
End With
NextCode:
With ActiveWorkbook
.ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value '<~~ converts contents of XLSX file to values only
.SaveAs filename:=MyPath & MyFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close False
End With
Application.EnableEvents = True
End Sub
Format(Date, "yyyymmdd") doesn't seem to work for the filename.
I would like to remove the drop down boxes I have in column A.
I would like to remove the shape boxes I use for my macros.
Basically want to strip the document to only dumb text so I can email it.
Thanks
You can remove validation by doing:
Activesheet.Cells.Validation.Delete
(though qualifying the sheet name would be ideal).
You can also loop through shapes within a worksheet by doing something like:
Dim shp as Shape
For each shp in ActiveSheet.Shapes
shp.delete
Next
These two steps should remove all shapes, and should remove all data validation.
I have VBA in Word that opens multiple files from a folder that I select, replaces the logo in the header with a new file that I direct it to, and then saves the files in a different folder.
I have the files saving in a different folder not because I want to, but because they are opening as read-only and I can't figure out how to make that not happen. I have tried everything I can find on here. I'm fine with them saving to a new folder. That's not the issue for me right now.
Right now, this code works, but I have to click "Save" for each document. I would like that to be automated. The code right here is the saveas
End With
With Dialogs(wdDialogFileSaveAs)
.Name = "\\i-worx-san-07.i-worx.ca\wardell$\Redirection\billy.bones\Desktop\Test 3\" & ActiveDocument.Name
.Show
End With
End With
objDocument.SaveAs
objDocument.Close (True)
The following is the complete VBA code. I'm an absolute novice, so go easy. I want to know how to go about making the saveas include the original filename, a new specified folder (can be specified in the code, doesn't have to be specified by the user) and do it without the user having to press "save" a brazillion times. I appreciate your help.
Sub Example1()
'Declaring the required variables
Dim intResult As Integer
Dim strPath As String
Dim arrFiles() As String
Dim i As Integer
'the dialog is displayed to the user
intResult = Application.FileDialog(msoFileDialogFolderPicker).Show
'checks if user has cancled the dialog
If intResult <> 0 Then
'dispaly message box
strPath = Application.FileDialog( _
msoFileDialogFolderPicker).SelectedItems(1)
'Get all the files paths and store it in an array
arrFiles() = GetAllFilePaths(strPath)
'Modifying all the files in the array path
For i = LBound(arrFiles) To UBound(arrFiles)
Call ModifyFile(arrFiles(i))
Next i
End If
End Sub
Private Sub ModifyFile(ByVal strPath As String)
Dim objDocument As Document
Set objDocument = Documents.Open(strPath)
With ActiveDocument.Sections(1)
With ActiveDocument.Sections(1)
.Headers(WdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Delete
End With
Dim imagePath As String
'Please enter the relative path of the image here
imagePath = "C://FILEPATH\FILENAME.jpg"
Set oLogo = .Headers(wdHeaderFooterPrimary).Range.InlineShapes.AddPicture(FileName:=imagePath, LinkToFile:=False, SaveWithDocument:=True)
With oLogo.Range
.ParagraphFormat.Alignment = wdAlignParagraphRight
'Right alignment for logo image
.ParagraphFormat.RightIndent = InchesToPoints(-0.6)
End With
End With
With oLogo
.Height = 320
.Width = 277
With Selection.PageSetup
'Header from Top value
.HeaderDistance = InchesToPoints(0.5)
End With
With Dialogs(wdDialogFileSaveAs)
.Name = "\\i-worx-san-07.i-worx.ca\wardell$\Redirection\billy.bones\Desktop\Test 3\" & ActiveDocument.Name
.Show
End With
End With
objDocument.SaveAs
objDocument.Close (True)
End Sub
Private Function GetAllFilePaths(ByVal strPath As String) _
As String()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
Dim arrOutput() As String
ReDim arrOutput(1 To 1)
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder(strPath)
i = 1
'loops through each file in the directory and
'prints their names and path
For Each objFile In objFolder.Files
ReDim Preserve arrOutput(1 To i)
'print file path
arrOutput(i) = objFile.Path
i = i + 1
Next objFile
GetAllFilePaths = arrOutput
End Function
Remove this line which calls the FileSaveAs dialogue.
With Dialogs(wdDialogFileSaveAs)
.Name = "\\i-worx-san-07.i-worx.ca\wardell$\Redirection\billy.bones\Desktop\Test 3\" & ActiveDocument.Name
.Show
End With
Then modify this line:
objDocument.SaveAs
and include the filepath like this:
objDocument.SaveAs "\\i-worx-san-07.i-worx.ca\wardell$\Redirection\" _
& "billy.bones\Desktop\Test 3\" & ActiveDocument.Name
In newer version of Word, it was change to SaveAs2 but SaveAs still works.
That method takes the file path where you want the file saved as first argument.
I'm trying to export text from a large ppt. I have figured out how to export but I get all text from all shapes and I'm only interested in certain text.
Is there a way to have an IF function that checks the formatting of the shape and grabs the text only if the IF function is true. I want to select text only from shapes with a dashed border. Is that possible?
This is the code I have
Sub ExportText()
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSld As Slide 'Slide Object
Dim oShp As Shape 'Shape Object
Dim iFile As Integer 'File handle for output
iFile = FreeFile 'Get a free file number
Dim PathSep As String
Dim FileNum As Integer
#If Mac Then
PathSep = ":"
#Else
PathSep = "\"
#End If
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
FileNum = FreeFile
'Open output file
' NOTE: errors here if file hasn't been saved
Open oPres.Path & PathSep & "AllText.TXT" For Output As FileNum
For Each oSld In oSlides 'Loop thru each slide
For Each oShp In oSld.Shapes 'Loop thru each shape on slide
'Check to see if shape has a text frame and text
If oShp.HasTextFrame And oShp.TextFrame.HasText Then
If oShp.Type = msoPlaceholder Then
Select Case oShp.PlaceholderFormat.Type
Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
Print #iFile, "Title:" & vbTab & oShp.TextFrame.TextRange
Case Is = ppPlaceholderBody
Print #iFile, "Body:" & vbTab & oShp.TextFrame.TextRange
Case Is = ppPlaceholderSubtitle
Print #iFile, "SubTitle:" & vbTab & oShp.TextFrame.TextRange
Case Else
Print #iFile, "Other Placeholder:" & vbTab & oShp.TextFrame.TextRange
End Select
Else
Print #iFile, vbTab & oShp.TextFrame.TextRange
End If ' msoPlaceholder
End If ' Has text frame/Has text
Next oShp
Next oSld
'Close output file
Close #iFile
End Sub
Here goes solution for you. Please refer to comments inside the code for further information.
Sub Partial_Solution()
'... your code here
'... your loops start here
'this way check which DashStyle is in your interest,
'there are lots of different Dash styles of line
'then you could remove it
Debug.Print oShp.Line.DashStyle
'and this way you can check the style before reading from shape
'put the result here, like 5 which is msoLineDashDot style
If oShp.Line.DashStyle = 5 Then
'... your code here
End If
'... rest of your code here
End Sub