从PPT中提取文本内容并作为word文档输出文件

Question

从随机站点获取dis代码，用于从PPT幻灯片中提取幻灯片和备注部分的文本内容。但是输出文件作为记事本给出。我想把o/p文件作为word文档。有人能帮忙吗？感谢你的提前

我对那些创造这些代码并简化我工作的人表示感谢。

选项显式

Sub ExportNotesText()
Dim oSlides As Slides
Dim oSl As Slide
Dim oSh As Shape
Dim strNotesText As String
Dim strFileName As String
Dim intFileNum As Integer
Dim lngReturn As Long

' Get a filename to store the collected text
strFileName = InputBox("Enter the full path and name of file to extract notes text to", "Output file?")
' did user cancel?
 If strFileName = "" Then
    Exit Sub
End If

' is the path valid?  crude but effective test:  try to create the file.
intFileNum = FreeFile()
On Error Resume Next
Open strFileName For Output As intFileNum
If Err.Number <> 0 Then     ' we have a problem
MsgBox "Couldn't create the file: " & strFileName & vbCrLf _ & "Please try again."
Exit Sub
End If
Close #intFileNum  ' temporarily
' Get the notes text  

Set oSlides = ActivePresentation.Slides

For Each oSl In oSlides
    strNotesText = strNotesText & "======================================" & vbCrLf
    strNotesText = strNotesText & "Slide" & oSl.SlideIndex & vbCrLf
    strNotesText = strNotesText & SlideText(oSl) & vbCrLf
    strNotesText = strNotesText & NotesText(oSl) & vbCrLf
   Next oSl
     
' now write the text to file
Open strFileName For Output As intFileNum
Print #intFileNum, strNotesText
Close #intFileNum

' show what we've done
lngReturn = Shell("NOTEPAD.EXE " & strFileName, vbNormalFocus)

End Sub
Function SlideText(oSl As Slide) As String
Dim oSh As Shape
Dim osld As Slide
Dim strNotesText As String
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
SlideText = SlideText & oSh.Name & ":" & " " & oSh.TextFrame.TextRange & vbCrLf
End If
End If
Next oSh
End Function

Function NotesText(oSl As Slide) As String
Dim oSh As Shape
For Each oSh In oSl.NotesPage.Shapes
    If oSh.PlaceholderFormat.Type = ppPlaceholderBody Then
        If oSh.HasTextFrame Then
            If oSh.TextFrame.HasText Then
                NotesText = oSh.TextFrame.TextRange.Text
            End If
        End If
    End If
Next oSh

端函数

Answer 1

例如：

Sub Demo()
'Note: A VBA Reference to Word is required.
'See under Tools|References
Dim WdApp As New Word.Application, wdDoc As Word.Document
Dim Sld As Slide, Shp As Shape
Set wdDoc = WdApp.Documents.Add
For Each Sld In ActivePresentation.Slides
  With Sld
    For Each Shp In .NotesPage.Shapes
      With Shp
        If .PlaceholderFormat.Type = ppPlaceholderBody Then
          If .HasTextFrame Then
            If .TextFrame.HasText Then
              wdDoc.Range.InsertAfter vbCr & Sld.SlideIndex & ": " & .TextFrame.TextRange.Text
            End If
          End If
        End If
      End With
    Next
    For Each Shp In .Shapes
      With Shp
        If .HasTextFrame Then
          If .TextFrame.HasText Then
            wdDoc.Range.InsertAfter vbCr & .Name & ": " & .TextFrame.TextRange.Text
          End If
        End If
      End With
    Next
  End With
Next
WdApp.Visible = True: wdDoc.Activate
Set wdDoc = Nothing: Set WdApp = Nothing
End Sub