Откройте PowerPoint из каталога и возобновите макрос

Question

Я пытаюсь открыть PPTX из определенной папки, используя функцию в сабвуфере. Цель функции состоит в том, чтобы выбрать файл, с которым будет выполнять остальная часть кода макроса (по сути, сделать его ActivePresentation). Проблема в том, что когда я вызываю функцию PickDir (), чтобы получить путь к файлу и открыть его, макрос перестает работать Итак, я просто получаю открытую презентацию, а не выполняю действие, которое хочу сделать.

Проблема возникает примерно через 5 строк после того, как все переменные 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

Вы запускаете это изнутри powerpoint?Если да, вам не нужно создавать другой объект Application: вы можете просто открыть ppt напрямую.И вы можете использовать возвращаемое значение из Open (), чтобы получить ссылку на презентацию (вместо использования «activePresentation»)

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

Answer 2

Если вам не нужно беспокоиться о том, какая презентация активна, вы можете сделать следующее:

Dim oPres as Presentation
Set oPres = oPP.Presentations.Open(SrcFile, False, False, True)

Затем в остальной части кода использовать oPres вместо ActivePresentation

Answer 3

Эта строка, вероятно, доставляет вам некоторые затруднения:

ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)

Я не знаю, как активировать окно в PPT, но, по крайней мере, вам нужно будет использовать следующее:

Set ActivePresentation = oPP.Presentations.Open(SrcFile, False, False, True)

Что касается активации презентации, вам может понадобиться доступ к коллекции окон или что-то подобное?Мы надеемся, что это заставит вас задуматься.

application.Presentations(1).Windows(1).Activate

Наконец, вам, возможно, не понадобится активировать презентацию, если у вас нет других открытых презентаций, та, которую вы открываете, скорее всего будет активнойодин по умолчанию, если вы открываете его видимым.Я подозреваю, что это так, учитывая, что вы создаете объект приложения Powerpoint.Если это правильно, вам просто нужно сделать следующее:

oPP.Presentations.Open(SrcFile, False, False, True)
debug.print oPP.ActivePresentation.Name

Редактировать: я бы также рекомендовал установить ссылку на библиотеку объектов powerpoint и объявить oPP следующим образом:

Dim oPP as Powerpoint.Application

Затем при создании экземпляра приложения:

Set oPP = New Powerpoint.Application