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

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:

Code:

---

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

---

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)

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.

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

I take it C:\MyFolder does actually exist?

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.

It works here.

Is OldPPT SAVED and is it a pptm?

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

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.

OMG you are a VBA Guru!!!

THANK YOU!! :bow:

I used:

Code:

---

  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.