Trying to write a code where I loop through a subfolder, update and rename a powerpoint with a new name, and then move the old one to an Archive folder. The first 2 parts work, but the last part does not. I end up with both the old file and the new one in the original path. What am I doing wrong?
If needed, the "update" is basically copying one slide from a different master deck and copying it into the powerpoint.
Sub CopyDepositModelingWSCards()
Dim AreaReport As Presentation, oSld As Slide
Dim MasterPPT As Presentation
Set MasterPPT = ActivePresentation
Dim MyFile As String
Dim fso As New FileSystemObject
filepath = [path]
Set f = CreateObject("Scripting.Filesystemobject").GetFolder(filepath)
i = 44 'used master ppt slide index
For Each subFolder In f.subfolders
Debug.Print subFolder.Name
'loop files in subfolders
If subFolder Like "*Completed*" Then
'Do nothing
ElseIf subFolder Like "*Archive*" Then
'Do nothing
Else
For Each f In subFolder.Files
If LCase(f.Name) Like "*.ppt*" Then
Debug.Print , f.Path
Set AreaReport = Presentations.Open(f, WithWindow:=msoTrue)
'get file name without file extension
currentFileName = Left(Application.ActivePresentation.Name, Len(Application.ActivePresentation.Name) - 5)
'set new file name with the current date
newFileName = ActivePresentation.Path & "\" & Left(currentFileName, Len(currentFileName) - 8) & Format(Now(), "YYYYMMDD")
With Application.ActivePresentation
SourceFileName = ActivePresentation.FullName
DestinFolder = ActivePresentation.Path & "\Archive\"
'Debug.Print (SourceFileName)
'Debug.Print (DestinFolder)
.SaveAs newFileName
MasterPPT.Slides(i).Copy
AreaReport.Slides.Paste (1)
AreaReport.Slides.Item(1).Design = _
MasterPPT.Slides.Item(2).Design
AreaReport.Slides(2).Delete
.SaveAs newFileName
On Error Resume Next
fso.MoveFile Source:=SourceFileName, Destination:=DestinFolder
'PowerPoint.Application.Presentations(SourceFileName).Close
fso.MoveFile Source:=SourceFileName, Destination:=DestinFolder
End With
AreaReport.Close
End If
Next f
End If
i = i + 1
Next subFolder
MsgBox ("Complete")
End Sub
You need to pass the full path - including the file name - to Destination
, so this should work:
fso.MoveFile source:=f.path, Destination:=f.parentfolder & "\Archive\" & f.Name
Also don't forget fso
has handy methods like GetBaseName
and GetExtensionName
which can replace some of that Left/Right/Mid code.