I have VBA code which replaces the value of the footer.text with "" and turns off footer visibility by Footer.Visible = msoFalse
Every time I set Footer.Visible to msoFalse, the footer text that was changed to "" reverts to the original text. (This can be seen while using PowerPoint -> insert -> Header & Footer -> Slide tab -> Footer dialogue box.)
The entry before changing the footer.text to "" returns.
If I do not change the visibility with Footer.visible=msoFalse, the change to the "" value is accepted.
'This will select the file/folder
Function select_folder()
Dim Filepicker As FileDialog
Dim mypath As String
Set Filepicker = Application.FileDialog(msoFileDialogFolderPicker)
With Filepicker
.Title = "Select folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.ButtonName = "Select(&S)"
If .Show = -1 Then
mypath = .SelectedItems(1) & "\"
Else
End
End If
End With
'Workbooks.Open fileName:=mypath
NextCode:
select_folder = mypath
Set Filepicker = Nothing
End Function
Sub ppt_delete()
Dim strInFold As String, strFile As String, PrsSrc As PowerPoint.Presentation
Dim extension As String
Dim PPApp As PowerPoint.Application
Dim PPSlide As PowerPoint.Slide
strInFold = select_folder
extension = "*.ppt*"
strFile = Dir(strInFold & extension)
Do While strFile <> ""
' Reference instance of PowerPoint
On Error Resume Next
' Check whether PowerPoint is running
Set PPApp = GetObject(, "PowerPoint.Application")
If PPApp Is Nothing Then
' PowerPoint is not running, create new instance
Set PPApp = CreateObject("PowerPoint.Application")
' For automation to work, PowerPoint must be visible
PPApp.Visible = True
End If
On Error GoTo 0
DoEvents
Set PrsSrc = PPApp.Presentations.Open(Filename:=strInFold & strFile)
For Each PPSlide In PrsSrc.Slides
PPSlide.HeadersFooters.Footer.Visible = msoTrue
PPSlide.HeadersFooters.Footer.Text = ""
'PPSlide.HeadersFooters.Footer.Visible = msoFalse
'you can comment and uncomment above line to test
DoEvents
Next PPSlide
PPApp.ActivePresentation.Save
PPApp.ActivePresentation.Close
strFile = Dir
Loop
PPApp.Quit
End Sub
Additional info. The script will first choose a folder where the .ppt* files are located. Script will check all the .ppt extensions in the folder, and make the changes.
How can I do this:
PPSlide.HeadersFooters.Footer.Visible = msoTrue
PPSlide.HeadersFooters.Footer.Text = ""
PPSlide.HeadersFooters.Footer.Visible = msoFalse
and make the changes to "" visible in powerpoint -> insert-> Header & Footer -> Slide tab -> Footer dialogue box.
Apparently, the footer value is hidden in the presentation. this is the reason why it always comes back.
The solution was to assign the footer.text to "" save and close, reopen the ppt, then switch to PPSlide.HeadersFooters.Footer.Visible = msoFalse
Another approach: Tag the parent slide with the text you want to apply, then when you want to make the hidden footer visible again, set it to the saved text in the tag. Advantage is that this is near instant, where saving and reopening could take quite a while if the presentation is large.
Sub Test()
Dim osl As Slide
For Each osl In ActivePresentation.Slides
With osl.HeadersFooters.Footer
.Text = "New Text"
SetText osl, "TEXT", .Text
.Visible = False
.Visible = True
.Text = GetText(osl, "TEXT")
End With
Next
End Sub
Function GetText(osl, sTagname As String)
GetText = osl.Tags(sTagname)
End Function
Function SetText(osl As Slide, sTagname As String, sText As String)
osl.Tags.Add sTagname, sText
End Function
Related
I have an existing piece of code (see below) for importing a batch of photos and creating a slide show. At present, the code is creating these slides on a blank background with a title only. How can I modify it so it will choose a specific slide layout from the Master slides? I know it has something to do with this line in the code:
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
I looked here and tried some ideas but I just keep getting bugs: Applying layout to a slide from specific Master
Here's the full program:
Sub ImportStuffFromTextFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
When you say you keep getting bugs, what do you mean?
Are you getting error messages? If so, what are the error numbers/descriptions? Where does the code break?
If not, and you're getting 'bugs', what should the final output look like and how does this differ from that?
I would say that one big unknown here is the text file input. According to your code, it seems as though it needs to have a series of filenames and corresponding picture descriptions on each line of the text file, separated by a tab. Critically, it must be a tab and not 2 spaces or 4 spaces or 10 spaces or a hyphen ... it must be a tab. Is that the structure of the text file you're using as input?
PowerPoint treats built-in layouts differently than custom ones. You can't call a custom layout by name. Instead, you have to loop through each custom layout to find the one that has the right name, then use it:
Sub AddSlideFromCustomLayout()
Dim oLayout As CustomLayout
Dim oSlide As Slide
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSlide = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
End Sub
Here's your listing with the code replacing the Set oSld line:
Sub ImportStuffFromTextFile()
Dim oLayout As CustomLayout
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSld = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
I am new to VBA and obviously I am missing something. My code works for opening a word doc and sending data to it BUT does NOT for an ALREADY OPEN word doc. I keep searching for an answer on how to send info from Excel to an OPEN Word doc/Bookmark and nothing works.
I hope it is okay that I added all the code and the functions called. I really appreciate your help!
What I have so far
Sub ExcelNamesToWordBookmarks()
On Error GoTo ErrorHandler
Dim wrdApp As Object 'Word.Application
Dim wrdDoc As Object 'Word.Document
Dim xlName As Excel.Name
Dim ws As Worksheet
Dim str As String 'cell/name value
Dim cell As Range
Dim celldata As Variant 'added to use in the test
Dim theformat As Variant 'added
Dim BMRange As Object
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wb = ActiveWorkbook
strPath = wb.Path
If strPath = "" Then
MsgBox "Please save your Excel Spreadsheet & try again."
GoTo ErrorExit
End If
'GET FILE & path of Word Doc/Dot
strPathFile = strOpenFilePath 'call a function in MOD1
If strPathFile = "" Then
MsgBox "Please choose a Word Document (DOC*) or Template (DOT*) & try again." 'strPath = Application.TemplatesPath
GoTo ErrorExit
End If
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
'NONE OF THESE WORK
Set wrdApp = GetObject(strPathFile, "Word.Application")
'Set wrdApp = Word.Documents("This is a test doc 2.docx")
'Set wrdApp = GetObject(strPathFile).Application
Else
'all ok 'Create a new Word Session
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
wrdApp.Activate 'bring word visiable so erros do not get hidden.
'Open document in word
Set wrdDoc = wrdApp.Documents.Open(Filename:=strPathFile) 'Open vs wrdApp.Documents.Add(strPathFile)<=>create new Document1 doc
End If
'Loop through names in the activeworkbook
For Each xlName In wb.Names
If Range(xlName).Cells.Count = 1 Then
celldata = Range(xlName.Value)
'do nothing
Else
For Each cell In Range(xlName)
If str = "" Then
str = cell.Value
Else
str = str & vbCrLf & cell.Value
End If
Next cell
'MsgBox str
celldata = str
End If
'Get format and strip away the spacing, negative color etc etc
'I know this is not right... it works but not best
theformat = Application.Range(xlName).DisplayFormat.NumberFormat
If Len(theformat) > 8 Then
theformat = Left(theformat, 5) 'was 8 but dont need cents
Else
'do nothing for now
End If
If wrdDoc.Bookmarks.Exists(xlName.Name) Then
'Copy the Bookmark's Range.
Set BMRange = wrdDoc.Bookmarks(xlName.Name).Range.Duplicate
BMRange.Text = Format(celldata, theformat)
'Re-insert the bookmark
wrdDoc.Bookmarks.Add xlName.Name, BMRange
End If
Next xlName
'Activate word and display document
With wrdApp
.Selection.Goto What:=1, Which:=2, Name:=1 'PageNumber
.Visible = True
.ActiveWindow.WindowState = wdWindowStateMaximize 'WAS 0 is this needed???
.Activate
End With
GoTo WeAreDone
'Release the Word object to save memory and exit macro
ErrorExit:
MsgBox "Thank you! Bye."
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit Sub
'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & "; There is a problem"
If Not wrdApp Is Nothing Then
wrdApp.Quit False
End If
Resume ErrorExit
End If
WeAreDone:
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
file picking:
Function strOpenFilePath() As String
Dim intChoice As Integer
Dim iFileSelect As FileDialog 'B
Set iFileSelect = Application.FileDialog(msoFileDialogOpen)
With iFileSelect
.AllowMultiSelect = False 'only allow the user to select one file
.Title = "Please... Select MS-WORD Doc*/Dot* Files"
.Filters.Clear
.Filters.Add "MS-WORD Doc*/Dot* Files", "*.do*"
.InitialView = msoFileDialogViewDetails
End With
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strOpenFilePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else
'nothing yet
End If
End Function
checking if file is open...
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Function FileLocked Error #" & str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function
ANSWER BELOW. Backstory... So, after input from you guys and more research I discovered that I needed to set the active word document by using the file selection the user picked and that is then passed via late binding to the sub as an object to process. NOW it works if the word file is not in word OR if it is currently loaded into word AND not even the active document. The below code replaces the code in my original question.
Set Object app as word.
grab the file name.
Make the word doc selected active to manipulate.
Set the word object to the active doc.
THANK YOU EVERYONE!
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
Set wrdApp = GetObject(, "Word.Application")
strPathFile = Right(strPathFile, Len(strPathFile) - InStrRev(strPathFile, "\"))
wrdApp.Documents(strPathFile).Activate ' need to set picked doc as active
Set wrdDoc = wrdApp.ActiveDocument ' works!
This should get you the object you need.
Dim WRDFile As Word.Application
Set WRDFile = GetObject(strPathFile)
'Have Microsoft Word 16.0 Object Library selected in your references
Dim wordapp As Object
Set wordapp = GetObject(, "Word.Application")
wordapp.Documents("documentname").Select
'works if you only have one open word document. In my case, I'm trying to push updates to word links from excel.
I have created a PowerPoint with custom slide layouts. I want to be able to create a new slide using one of these custom layouts using Excel VBA, but I cannot figure out the correct syntax.
This is the code I currently have:
Sub runPPT()
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("SG2")
Dim pptName As String
Dim ppt As Object
Dim myPres As Object
Dim slds As Object
Dim sld As Object
MsgBox ("Please choose PowerPoint to open.")
pptName = openDialog()
Set ppt = CreateObject("PowerPoint.Application")
Set myPres = ppt.Presentations.Open(pptName)
Set slds = myPres.Slides
'This is where I want to add my custom layout
'My layouts all have similar names like "Gate 2 Main" if that helps
Set sld = slds.AddSlides(Slides.Count + 1, ActivePresentation.SlideMaster.CustomLayouts(1))
Application.ScreenUpdating = True
End Sub
Private Function openDialog()
Dim fd As Office.FileDialog
Dim txtFileName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Clear out the current filters, and add our own.
.Filters.Clear
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
openDialog = txtFileName
End Function
I was able to fix my issue by changing my code to the following:
Sub runPPT()
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Sheets("SG2")
Dim pptName As String
Dim ppt As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim slds As PowerPoint.Slides
Dim sld As PowerPoint.slide
Dim oLayout As CustomLayout
MsgBox ("Please choose PowerPoint to open.")
pptName = openDialog()
Set ppt = CreateObject("PowerPoint.Application")
Set myPres = ppt.Presentations.Open(pptName)
Set slds = myPres.Slides
Set sld = slds.Add(myPres.Slides.Count + 1, ppLayoutBlank)
For Each oLayout In myPres.Designs("Gate Main").SlideMaster.CustomLayouts
If oLayout.Name = "Gate 2 Main" Then
sld.CustomLayout = oLayout
Exit For
End If
Next
Application.ScreenUpdating = True
End Sub
Private Function openDialog()
Dim fd As Office.FileDialog
Dim txtFileName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
' Set the title of the dialog box.
.Title = "Please select the file."
' Clear out the current filters, and add our own.
.Filters.Clear
' Show the dialog box. If the .Show method returns True, the
' user picked at least one file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
openDialog = txtFileName
End Function
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 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