Question

I’m trying to open a PPTX from a specific folder using a Function within a Sub. The function’s purpose is to choose the file that the rest of the macro’s code will perform it on (essentially to make it the ActivePresentation) The problem is that when I call the function PickDir() to get the file’s path and open it, the macro stops running. So, I just get an open presentation and not performing the action I want it to do.

The problem occurs about 5 lines after all the variables are Dim’d.

Sub ExtractImagesFromPres()
On Error GoTo ErrorExtract
Dim oSldSource As Slide
Dim oShpSource As Shape
Dim ImgCtr As Integer
Dim SldCtr As Integer
Dim ShapeNameArray() As String
Dim oPP As Object
Dim SrcDir As String
Dim SrcFile As String
'File naming variables
Dim PPLongLanguageCode As String
Dim PPShortLanguageCode As String
Dim FNShort As String
Dim FNLong As String
Dim PPLanguageParts1() As String
Dim PPLanguageParts2() As String
Dim FNLanguageParts() As String

SrcDir = PickDir()      'call the PickDir() function to choose a directory to work from
If SrcDir = "" Then Exit Sub

SrcFile = SrcDir & "\" & Dir(SrcDir + "\*.pptx")    'complete directory path of ppt to be split

Set oPP = CreateObject("Powerpoint.Application")      'open ppt containing slides with images/text to be exported
ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)

ImgCtr = 0  'Image and Slide counter for error messages
SldCtr = 1

ReDim ShapeNameArray(1 To 1) As String  'initialize ShapeNameArray to avoid null array errors

For Each oSldSource In ActivePresentation.Slides
    For Each oShpSource In oSldSource.Shapes    'loop each shape within each slide
        If oShpSource.Type <> msoPlaceholder Then   'if shape is not filename placeholder then add it's name to ShapeNameArray
            ShapeNameArray(UBound(ShapeNameArray)) = oShpSource.Name
            ReDim Preserve ShapeNameArray(1 To UBound(ShapeNameArray) + 1) As String    'need to add one to array for new shape name
            ElseIf oShpSource.Type = msoPlaceholder Then    'is shape is filename placeholder then check to see if not empty
                If oShpSource.TextFrame.TextRange.Length = 0 Then
                    MsgBox "The filename is missing on Slide:" & SldCtr & vbNewLine & _
                    "Please enter the correct filname and re-run this macro"
                    Exit Sub
                End If
                PPLanguageParts1 = Split(ActivePresentation.Name, ".")  'extract language code from PowerPoint filename
                PPLongLanguageCode = PPLanguageParts1(LBound(PPLanguageParts1))
                PPLanguageParts2 = Split(PPLongLanguageCode, "_")
                PPShortLanguageCode = PPLanguageParts2(UBound(PPLanguageParts2))
                FNLanguageParts = Split(oShpSource.TextFrame.TextRange.Text, "_")   'insert PowerPoint filename language code into image filename language code
                FNShort = FNLanguageParts(LBound(FNLanguageParts))
                FNLong = FNShort & "_" & PPShortLanguageCode
                oShpSource.TextFrame.TextRange.Text = FNLong

        End If
    Next oShpSource
        ReDim Preserve ShapeNameArray(1 To UBound(ShapeNameArray) - 1) As String    'ShapeNameArray has one too many elements, so subtract one
        Call oSldSource.Shapes.Range(ShapeNameArray).Export(FNLong & ".jpg", ppShapeFormatJPG)  'export images with proper filenames
        ReDim ShapeNameArray(1 To 1) As String
        ImgCtr = ImgCtr + 1
        SldCtr = SldCtr + 1
Next oSldSource

If ImgCtr = 0 Then  'error message if no images
    MsgBox "There were no images found in this presentation", _
            vbInformation, "Image extraction failed."
End If
Exit Sub
ErrorExtract:

If Err.Number <> 0 Then 'error message log
    MsgBox Err.Description, vbCritical, "Error #" & Err.Number
End If
End Sub

Private Function PickDir() As String
Dim FD As FileDialog

    PickDir = ""

    Set FD = Application.FileDialog(msoFileDialogFolderPicker)      'initialize default MS directory picker
    With FD
        .Title = "Pick the folder where your files are located"     'title for directory picker dialog box
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count <> 0 Then
            PickDir = .SelectedItems(1)
        End If
    End With

Answer 1

Are you running this from within powerpoint? If yes, you don’t need to create another Application object: you can just open the ppt directly. And you can use the return value from Open() to get a reference to the presentation (rather than using “activePresentation”)

Dim ppt as Presentation
Set ppt = Application.Presentations.Open(SrcFile, False, False, True)
'do stuff with ppt