Adapt VBA to save selected slides to a default folder with the original file name

[RayKay]

Hi John

I have this code, which works great, selected slides are added to a new file ready to save.
Is there a way for it to save the slides to a specific folder, i.e. C:\MyFolder and name the file with the same filename maybe? This doesn't affect the folder slides are taken from, that just stays open.

Thank you :dau:



Sub SaveToFolder()

Dim NewPPT As Presentation
Dim OldPPT As Presentation
Dim Selected_slds As SlideRange
Dim Old_sld As Slide
Dim New_sld As Slide
Dim Swap As Variant
Dim x As Long, y As Long
Dim myArray() As Long
Dim SortTest As Boolean
Set OldPPT = ActivePresentation
Set Selected_slds = ActiveWindow.Selection.SlideRange
ReDim myArray(1 To Selected_slds.Count)
For y = LBound(myArray) To UBound(myArray)
myArray(y) = Selected_slds(y).SlideIndex
Next y
Do
SortTest = False
For y = LBound(myArray) To UBound(myArray) - 1
If myArray(y) > myArray(y + 1) Then
Swap = myArray(y)
myArray(y) = myArray(y + 1)
myArray(y + 1) = Swap
SortTest = True
End If
Next y
Loop Until Not SortTest

'Set variable equal to only selected slides in Active Presentation (in numerical order)
Set Selected_slds = OldPPT.Slides.Range(myArray)


'Create a brand new PowerPoint presentation
Set NewPPT = Presentations.Add

'Align Page Setup
NewPPT.PageSetup.SlideHeight = OldPPT.PageSetup.SlideHeight
NewPPT.PageSetup.SlideOrientation = OldPPT.PageSetup.SlideOrientation
NewPPT.PageSetup.SlideSize = OldPPT.PageSetup.SlideSize
NewPPT.PageSetup.SlideWidth = OldPPT.PageSetup.SlideWidth


'Loop through slides in SlideRange
For x = 1 To Selected_slds.Count

'Set variable to a specific slide
Set Old_sld = Selected_slds(x)

'Copy Old Slide
y = Old_sld.SlideIndex
Old_sld.Copy

'Paste Slide in new PowerPoint
NewPPT.Slides.Paste
Set New_sld = Application.ActiveWindow.View.Slide

'Bring over slides design
New_sld.Design = Old_sld.Design

'Bring over slides custom color formatting
New_sld.ColorScheme = Old_sld.ColorScheme

'Bring over whether or not slide follows Master Slide Layout (True/False)
New_sld.FollowMasterBackground = Old_sld.FollowMasterBackground

Next x
End Sub

[John Wilson]

This is off the top of head and totally untested but you should be able to add before End Sub

call NewPPT.SaveCopyAs ("C:\MyFolder " & OldPPT.Name)

[RayKay]

Hi John, thanks, but unfortunately it doesn't work, or save. I guessed:

.Application.ActivePresentation .SaveCopyAs ("C:\MyFolder" & OldPPT.Name)
.Application.ActivePresentation .SaveAs ("C:\MyFolder" & OldPPT.Name)
.ActivePresentation PpSaveAsFileType("C:\MyFolder")

But throws up an error too and doesn't save either.

Even just opening the SaveAs window over the C:\MyFolder would suffice and the person gives the filename.

Thanks you in advance.

[John Wilson]

Maybe should be
call NewPPT.SaveCopyAs ("C:\MyFolder\ " & OldPPT.Name)

I take it C:\MyFolder does actually exist?

[RayKay]

Hi John, yes the folder C:\MyFolder exists. I tried the code with the \ but still stayed as if the code wasn't there. It puts the selected slides into a new file, as wanted, named Presentation# (without .pptx and not saved); Save As opens the default folder (i.e. Libraries > Documents). Thank you.

[John Wilson]

It works here.

Is OldPPT SAVED and is it a pptm?

You probably need to change SaveCopyAs to a simple SaveAs too.

[RayKay]

Hi John, thanks for your quick reply :hi: the OldPPT is a saved .pptx

The main file would be a *.PPTX, and the slides taken out would saved as *.PPTX

So they may have it open from D:\ or Z:\ drive, say, but after running this VBA and pulling out selected slides, it would then save the new file to C:\MyFolder with the same filename, or that popup where it navigates to C:\MyFolder and the person needs to name that file (a better option I guess).

Thank you. And thanks for all your past help. This weekend I'm adding these tools to the ribbon then visiting my nephew, but I'll be back Thursday with any reply after 4 pm BST. Thank you.

[RayKay]

OMG you are a VBA Guru!!!

THANK YOU!! :bow:

I used:



Next x

Call NewPPT.SaveAs("C:\MyVault\ " & OldPPT.Name)

Exit Sub
err:
MsgBox "Please select slides in an open presentation and then save to your personal vault. You MUST have a folder C:\MyFolder"


End Sub


Have a wonderful weekend! Will mark this as solved.