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