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

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.

Code:

---

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

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.

Code:

---

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

---

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

Try this

Code:

---

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

---

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!!!!!!!!!

<blush>

No, just a plodder

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

</blush>

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