VBA Save file to user desktop, close existing file and open saved file?

[gmooney100]

Hi,

I would like to create VBA that will make a copy oy the currently opened .pptm file to the users desktop, close the current file that the macro is in, and open the newly save filed from the desktop.

Any help?

[John Wilson]

Try this.

If you need the macro preserved use pptm instead of pptx


Sub do_that()
Dim opres As Presentation
Set opres = ActivePresentation
ActivePresentation.SaveCopyAs Environ("USERPROFILE") & "\Desktop\copy.pptx"
Presentations.Open Environ("USERPROFILE") & "\Desktop\copy.pptx"
opres.Close
End Sub

[Artik]

John, for me, PP would never find the path Environ("USERPROFILE") & "\Desktop\. :devil2:
gmooney, the SaveCopyAs method saves a copy of the file to the location you specified, but the original file remains active. The SaveAs method saves the file with a new name at the specified location, the original file is closed, and the new file becomes active. But be careful! When saving with the SaveAs method, the original file is dropped without saving the changes. If you make changes from the moment of opening the file, until saving under a new name, and you want to save them in a copy, you need to save the file using the Save method and then use SaveAs.Below is a macro using the SaveAs method and a safer way to locate the Desktop.
Sub do_that_1()


With ActivePresentation
'.Save '- if needed
.SaveCopyAs GetDesktopPath & "copy.pptx"
End With
End Sub




Function GetDesktopPath()
Dim WSHShell As Object


Set WSHShell = CreateObject("Wscript.Shell")
GetDesktopPath = WSHShell.SpecialFolders(4)
If Right(GetDesktopPath, 1) <> "\" Then
GetDesktopPath = GetDesktopPath & "\"
End If
End Function
Artik

[gmooney100]

Artik,

The user will be adding 25 slides from another PPT file via the Reuse slides options. Then they are supposed to run the following code below that I currently have. It essentially rearranges the slides an deletes on slide. My save code can be modified to use what you think is the best from your code. I do not believe that I need to existing PPT macro file to ever be saved.

Sub RearrangeSlidesToNewLocation()


Dim strName As String


ActivePresentation.Slides(2).MoveTo toPos:=34
ActivePresentation.Slides(2).MoveTo toPos:=34
ActivePresentation.Slides(2).MoveTo toPos:=36
ActivePresentation.Slides(2).MoveTo toPos:=36
ActivePresentation.Slides(2).MoveTo toPos:=38
ActivePresentation.Slides(2).MoveTo toPos:=38
ActivePresentation.Slides(2).MoveTo toPos:=38
ActivePresentation.Slides(2).MoveTo toPos:=38
ActivePresentation.Slides(2).MoveTo toPos:=38
ActivePresentation.Slides(2).MoveTo toPos:=38
ActivePresentation.Slides(2).MoveTo toPos:=38
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=40
ActivePresentation.Slides(2).MoveTo toPos:=42
ActivePresentation.Slides(2).MoveTo toPos:=42
ActivePresentation.Slides(2).MoveTo toPos:=42
ActivePresentation.Slides(2).MoveTo toPos:=42
ActivePresentation.Slides(2).MoveTo toPos:=42






strName = ActivePresentation.Slides(2).Shapes("Title 1").TextFrame.TextRange.Text
ActivePresentation.Slides(2).Delete
ActivePresentation.Slides(1).Select


With Application.ActivePresentation
.SaveCopyAs strName
End With






MsgBox "Your new Category Review has been saved. Please close this file and open the newly saved file. You can then begin your Category Review work."


End Sub

[Artik]

Gmooney, please use
tags when quoting your code (use # button).
I made an obvious mistake in the previous post. I was talking about SaveAs, but I wrote SaveCopyAs in the code. I'm sorry.

You can also write your code this way:[CODE]Sub RearrangeSlidesToNewLocation()
Dim i As Long
Dim varrPos As Variant


varrPos = Array(34, 34, _
36, 36, _
38, 38, 38, 38, 38, 38, 38, _
40, 40, 40, 40, 40, 40, 40, 40, 40, _
42, 42, 42, 42, 42)


With ActivePresentation
For i = 0 To UBound(varrPos)
.Slides(2).MoveTo toPos:=varrPos(i)
Next i


strName = .Slides(2).Shapes("Title 1").TextFrame.TextRange.Text
.Slides(2).Delete
.Slides(1).Select


.SaveAs GetDesktopPath & strName & ".pptx"
End With


MsgBox "Your new Category Review has been saved." & vbLf & _
"You can start work.", vbInformation
End Sub plus GetDesktopPath function.

Artik

[gmooney100]

Artik,

This doesn't seem to do the saving of the file and I do not get the message box at the end. It does all the rearranging of the slides and deletes the slide 1 and selects slide 1.

One thing I failed to mention; the user will need to put the PPT into slide show mode in order to click on an action button to fire the macro. Maybe this is causing problems?

Where does the function code go and how does it get called? Does it go in Module 1 with this Macro?

Also, can you tell me what versions of PPT this code will work on?