Question

我正在尝试使用Sub中的Function从特定文件夹打开PPTX。该函数的目的是选择宏的代码的其余部分将执行它的文件（主要是使它成为ActivePresentation）问题是，当我调用函数PickDir（）来获取文件的路径并打开它时，宏停止运行。所以，我只是得到一个开放的演示文稿，而不是执行我希望它执行的操作。

在所有变量都变暗后，问题发生在5行左右。

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

这条线可能会给你带来一些麻烦：

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

我不知道如何在PPT中激活窗口，但至少你需要使用以下内容：

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

至于激活演示文稿，您可能需要访问Windows集合或类似的东西？一个建议，希望能让你思考。

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

Answer 3

如果您不想担心哪个演示文稿处于活动状态，您可以执行以下操作：

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

然后在其余代码中，使用oPres而不是ActivePresentation

从目录打开PowerPoint并恢复宏

3 个答案: