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

Question

Я пытаюсь открыть PPTX из определенной папки, используя функцию в Sub. Целью функции является выбор файла, в котором будет выполняться код остальной части макроса (по существу, чтобы сделать его 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? Если да, вам не нужно создавать другой объект приложения: вы можете просто открыть ppt напрямую. И вы можете использовать возвращаемое значение Open(), чтобы получить ссылку на презентацию (а не с помощью «activePresentation»)

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

Answer 2

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

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

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

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 

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

Dim oPP as Powerpoint.Application 

Тогда, когда создавая экземпляр заявки:

Set oPP = New Powerpoint.Application 

Answer 3

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

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

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