VBA用于打开和编辑多个Powerpoint文件

Question

I have a folder with over 200 Powerpoint files and I have been have been struggling with a Macro that opens each of these files, edits them, saves them and closes them in a loop. I have managed to create code for the editing part, however I can't manage to create a code that picks each of the files in the folder. Using "*.pptx" doesn't seem to work and writing code with a specific filename for each of these files is very inefficient.

Does anyone have a solution to this?

Sub SaveNotesText()

Dim oPres As Presentation
Dim oSlides As Slides
Dim oSlide As Slide
Dim oShapes As Shapes
Dim oSh As Shape
Dim NotesText As String
Dim FileNum As Integer
Dim PathSep As String

#If Mac Then
    PathSep = ":"
#Else
    PathSep = "\"
#End If

Set oPres = ActivePresentation
Set oSlides = oPres.Slides

For Each oSlide In oSlides
    NotesText = NotesText & "Slide " & oSlide.SlideIndex & vbCrLf
    Set oShapes = oSlide.NotesPage.Shapes
    For Each oSh In oShapes
        If oSh.HasTextFrame Then
            If oSh.TextFrame.HasText Then
                NotesText = NotesText & oSh.TextFrame.TextRange.Text
            End If
        End If
    Next oSh
    NotesText = NotesText & vbCrLf
Next oSlide

FileNum = FreeFile
Open oPres.Path & PathSep & "NotesText.TXT" For Output As FileNum
Print #FileNum, NotesText
Close FileNum

End Sub

http://www.pptfaq.com/FAQ00274.htm

Answer 1

You can use Dir to loop through all the "#.ppt#" files in a folder, ie

Public Sub DoFiles()
    Dim strFileName As String
    Dim strFolderName As String
    Dim PP As Presentation
    'set default directory here if needed
    strFolderName = "C:\temp"
    strFileName = Dir(strFolderName & "\*.ppt*")
    Do While Len(strFileName) > 0
       Set PP = Presentations.Open(strFolderName & "\" & strFileName)
        'your code
        PP.Close
        strFileName = Dir
    Loop
End Sub