打开方法无法从 ppt 打开 ppt

Question

我在这里遇到了一些麻烦。我的代码因运行时间错误 -2147467259 (80004005) Mehod 'Open' of object 'Presentations: failed.

而停止

此代码会发出警告，提示输入源文件夹和目标文件夹并循环遍历源文件夹中的所有文件，打开每个文件并将每张幻灯片导出为单独的文件，然后再次直到文件夹中的最后一个文件。

我放了几个消息框看看是不是名字有问题，根据 MVP Andy Pope 的一些代码重写了打开的文件段，但没有。

非常感谢任何帮助。

Sub ExportIndividualSlides()
    ''Application.DisplayAlerts = False
    
    Dim ObjPPAPP As New PowerPoint.Application
    Dim objPPPres As PowerPoint.Presentation
    Dim objPPSlide As PowerPoint.Slide
    
    'Initial directory path.
    Dim SourceFolder As String
    Dim TargetFolder As String
    SourceFolder = "c:\source"
    TargetFolder = "c:\target"
    
    Dim Slide As Long
    Dim SourcePresentation As Presentation
    Dim SourcePresentationName As String
    Dim TargetFileName As String
    Dim SourceNamePath
    
    Debug.Print "-- Start --------------------------------"
    
    ActiveWindow.ViewType = ppViewNormal
    
    'Loop through ppt* files only in source folder
       
        SourcePresentationName = Dir(SourceFolder & "\*.ppt*")
            
        MsgBox "SPN:" & SourcePresentationName
            
        While (SourcePresentationName <> "")
            
            SourceNamePath = SourceFolder & "\" & SourcePresentationName
            Debug.Print "   SourceNamePath"
            
            MsgBox SourceNamePath
            
            Set ObjPPAPP = New PowerPoint.Application
            ObjPPAPP.Visible = True
            Set objPPPres = ObjPPAPP.Presentations.Open(SourceNamePath)
            
        '    On Error GoTo errorhandler
            
            ' Open source files
            Set SourcePresentation = Presentations.Open(FileName:=SourcePresentationName, WithWindow:=False)
            Debug.Print "   SourcePresentation: " & SourcePresentation.Name
        
            ' Loop through slides
            For Slide = 1 To SourcePresentation.Slides.Count
            Debug.Print "   Slide: " & Slide
               
                ' Create a unique filename and save a copy of each slide
                TargetFileName = Left(SourcePresentation.Name, InStrRev(SourcePresentation.Name, ".") - 1) & " [" & Slide & "].pptx"
                TargetNamePath = TargetFolder & "\" & TargetFileName
                Debug.Print "   TargetNamePath: " & TargetNamePath
                SourcePresentation.Slides(Slide).Export TargetNamePath, "PPTX"
            
            Next Slide
            objPPPres = Nothing
            SourcePresentation.Close
            SourcePresentationName = Dir
        Wend
    
    
      On Error GoTo 0
      Exit Sub
     
errorhandler:
      Debug.Print Err, Err.Description
      Resume Next
    
End Sub

Answer 1

这对我有用：

Sub ExportIndividualSlides()
    'use const for fixed values
    Const SOURCE_FOLDER As String = "c:\source\" 'include terminal \
    Const TARGET_FOLDER As String = "c:\target\"
    
    Dim objPres As PowerPoint.Presentation
    Dim Slide As Long
    Dim SourcePresentationName As String
    Dim TargetFileName As String
    Dim TargetNamePath As String
    Dim SourceNamePath
    
    Debug.Print "-- Start --------------------------------"
    ActiveWindow.ViewType = ppViewNormal
    
    On Error GoTo errorhandler
    
    'Loop through ppt* files only in source folder
    SourcePresentationName = Dir(SOURCE_FOLDER & "*.ppt*")
    Do While Len(SourcePresentationName) > 0
        
        SourceNamePath = SOURCE_FOLDER & SourcePresentationName
        Debug.Print "Opening: " & SourceNamePath
        
        Set objPres = Presentations.Open(SourceNamePath)
        
        ' Loop through slides
        For Slide = 1 To objPres.Slides.Count
            
            Debug.Print "   Slide: " & Slide
            ' Create a unique filename and save a copy of each slide
            TargetFileName = Left(objPres.Name, InStrRev(objPres.Name, ".") - 1) & " [" & Slide & "].pptx"
            TargetNamePath = TARGET_FOLDER & TargetFileName
            Debug.Print "   TargetNamePath: " & TargetNamePath
            objPres.Slides(Slide).Export TargetNamePath, "PPTX"
        
        Next Slide
        
        objPres.Close
        
        SourcePresentationName = Dir() 'next file
    Loop
    
    Exit Sub
     
errorhandler:
    Debug.Print Err, Err.Description
    Resume Next
    
End Sub

打开方法无法从 ppt 打开 ppt

Open method not working to open ppts from a ppt

vba

powerpoint