Sub ExtractTextToWordDoc()
Dim objPresentation As Presentation
Dim objSlide As Slide
Dim objShape As Shape
Dim objTextFrame As TextFrame
Dim objTextRange As TextRange
Dim strOutput As String
Dim objWord As Object
Dim objDoc As Object
Set objPresentation = ActivePresentation
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Add
For Each objSlide In objPresentation.Slides
For Each objShape In objSlide.Shapes
If objShape.HasTextFrame Then
Set objTextFrame = objShape.TextFrame
Set objTextRange = objTextFrame.TextRange
strOutput = strOutput & objTextRange.Text & vbCrLf
End If
Next
Next
objDoc.Range.InsertAfter strOutput
objDoc.SaveAs "D:\Output.docx"
objDoc.Close
objWord.Quit
MsgBox "文本提取已完成！"
End Sub