How to prompt User for Folder path that holds all Presentations for compilation

[Hemsat]

Hi,

I am trying to create a macro that will compile all presentations. I want to be able to open up a ppt, run the macro and have a prompt for choosing the folder that will contain all the presentations to be combined. I found something that will work if the files are stored in a test folder on the desktop but tried to modify it for prompt with no success. Please help.


Sub Combine()


Dim sFileTyp As String
Dim sFileName As String
Dim oDonor As Presentation
Dim otarget As Presentation
Dim i As Integer
On Error GoTo errhandler
sFileTyp = "*.PPTX"


sFileName = Dir$(Environ("USERPROFILE") & "\Desktop\Test\" & sFileTyp)
Set otarget = ActivePresentation
Do While sFileName <> ""
Set oDonor = Presentations.Open(Environ("USERPROFILE") & "\Desktop\Test\" & sFileName, msoFalse)
For i = 1 To oDonor.Slides.Count
oDonor.Slides(i).Copy
With otarget.Slides.Paste(otarget.Slides.Count + 1)
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With
Next i
oDonor.Close
Set oDonor = Nothing
sFileName = Dir()
Loop




MsgBox "DONE!"


NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit




Exit Sub


errhandler:


MsgBox "Sorry, there was an error"


End Sub



Thanks,
Hema

[Paul_Hossler]

The function browseFolder will allow the user to select a folder and return it in a path.

The Dir loop reads the .pptx files in that folder

You'd need to open the pptx's and combine slides, etc.




Option Explicit

Sub test()
Dim sFolder As String, sFile As String
sFolder = browseFolder(, "Where are the PowerPoints?")
If Len(sFolder) = 0 Then Exit Sub
sFile = Dir(sFolder & "\*.pptx")

Do While Len(sFile) > 0

MsgBox sFolder & "\" & sFile

sFile = Dir
Loop
End Sub

'returns file name as string, vbnullstring if canceled
Function browseFolder(Optional sInitFolder As String = vbNullString, _
Optional Title As String = "Select Folder or Cancel to Exit") As String
Dim fd As FileDialog
If Len(sInitFolder) = 0 Then sInitFolder = CreateObject("Shell.Application").Namespace(CVar(5)).Self.Path
If Right(sInitFolder, 1) <> "\" Then sInitFolder = sInitFolder & "\"
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.InitialFileName = sInitFolder
.Title = Title
If .Show = -1 Then
browseFolder = .SelectedItems(1)
Else
browseFolder = vbNullString
End If
End With
Set fd = Nothing
End Function

[Hemsat]

Thank you, Paul! Ok, so how to assign the value for sFileName and oDonor in my code. I was trying to combine yours and mine but erroring out. Sorry, I am very new to Powerpoint VBA and except for a couple of tasks, we don't use it that much. I appreciate if you could combine yours and mine to prompt the user for folder path and combine the slides in the active presentation.

Thanks,
Hema

[Paul_Hossler]

Try this



Option Explicit

Sub Combine()

Dim sFileTyp As String
Dim sFileName As String, sFolder As String
Dim oDonor As Presentation
Dim oTarget As Presentation
Dim i As Integer

On Error GoTo errhandler

Set oTarget = ActivePresentation

sFileTyp = "*.PPTX"

sFolder = browseFolder(, "Where are the PowerPoints?")
If Len(sFolder) = 0 Then Exit Sub

sFileName = Dir(sFolder & "\" & sFileTyp)

Do While Len(sFileName) > 0

Set oDonor = Presentations.Open(sFolder & "\" & sFileName, msoFalse)
For i = 1 To oDonor.Slides.Count
oDonor.Slides(i).Copy
With oTarget.Slides.Paste(oTarget.Slides.Count + 1)
.Design = oDonor.Slides(i).Design
.ColorScheme = oDonor.Slides(i).ColorScheme
End With
Next I
oDonor.Close
Set oDonor = Nothing
sFileName = Dir()
Loop


MsgBox "DONE!"


NormalExit:
Exit Sub
ErrorHandler:
Call MsgBox("Error:" & vbCrLf & Err.Number & vbCrLf & Err.Description, _
vbOKOnly, "Error inserting files")
Resume NormalExit

Exit Sub


errhandler:


MsgBox "Sorry, there was an error"


End Sub

'returns file name as string, vbnullstring if canceled
Function browseFolder(Optional sInitFolder As String = vbNullString, _
Optional Title As String = "Select Folder or Cancel to Exit") As String
Dim fd As FileDialog
If Len(sInitFolder) = 0 Then sInitFolder = CreateObject("Shell.Application").Namespace(CVar(5)).Self.Path
If Right(sInitFolder, 1) <> "\" Then sInitFolder = sInitFolder & "\"
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.InitialFileName = sInitFolder
.Title = Title
If .Show = -1 Then
browseFolder = .SelectedItems(1)
Else
browseFolder = vbNullString
End If
End With
Set fd = Nothing
End Function

[Hemsat]

This works beautifully! Paul, you have no idea how much time you saved for me! You are a Powerpoint Guru and awesome!! Thanks a ton!!!!!!!!!

[Paul_Hossler]

<blush>

No, just a plodder

There's a lot of people here that are head and shoulders way more better than me

</blush>

[Hemsat]

That's very humble of you!! Thanks again!!