0

我正在尝试使用 Sub 中的函数从特定文件夹中打开 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
4

3 回答 3

1

你是从PowerPoint中运行这个吗？如果是，则不需要创建另一个应用程序对象：您可以直接打开 ppt。您可以使用 Open() 的返回值来获取对演示文稿的引用（而不是使用“activePresentation”）

Dim ppt as Presentation
Set ppt = Application.Presentations.Open(SrcFile, False, False, True)
'do stuff with ppt
于 2012-03-16T01:06:08.060 回答
0

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

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
于 2012-03-16T00:15:17.127 回答
0

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

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

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

于 2012-03-16T18:21:31.800 回答