PPT转换为TXT
请使用office来实现以下的功能。可以将PPT中所有的可编辑文本提取出来。在PPT中按ALT+F11。然后点击插入、然后选择模块,把下面的内容复制进去,执行。就可以在PPT所在的目录下面产生一个对应的TXT文件。
Sub ExportText()
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSld As Slide 'Slide Object
Dim oShp As Shape 'Shape Object
Dim iFile As Integer 'File handle for output
iFile = FreeFile 'Get a free file number
Dim PathSep As String
Dim FileNum As Integer
Dim sTempString As String
#If Mac Then
PathSep = "/"
#Else
PathSep = "\"
#End If
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
FileNum = FreeFile
'Open output file
' NOTE: errors here if file hasn't been saved
'Open oPres.Path & PathSep & "AllText.txt" For Output As FileNum
Open oPres.Path & PathSep & oPres.Name & ".txt" For Output As FileNum
num_slides = ActivePresentation.Slides.Count
For i = 1 To num_slides
Set oSld = ActivePresentation.Slides(i)
Print #iFile, "Slide:" & vbTab & CStr(oSld.SlideNumber)
For Each oShp In oSld.Shapes
'Check to see if shape has a text frame and text
If oShp.HasTextFrame And oShp.TextFrame.HasText Then
If oShp.Type = msoTextBox Then ' Check if shape is a TextBox
Print #iFile, "文本框:" & vbTab & oShp.TextFrame.TextRange
ElseIf oShp.Type = msoPlaceholder Then
Select Case oShp.PlaceholderFormat.Type
Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
Print #iFile, "标题:" & vbTab & oShp.TextFrame.TextRange
Case Is = ppPlaceholderBody
Print #iFile, "正文:" & vbTab & oShp.TextFrame.TextRange
Case Is = ppPlaceholderSubtitle
Print #iFile, "副标题:" & vbTab & oShp.TextFrame.TextRange
Case Else
Print #iFile, "其他占位符:" & vbTab & oShp.TextFrame.TextRange
End Select
Else ' it doesn't have a textframe - it might be a group that contains text so:
If oShp.Type = msoGroup Then
sTempString = TextFromGroupShape(oShp)
If Len(sTempString) > 0 Then
Print #iFile, sTempString
End If
ElseIf oShp.Type = msoSmartArt Then
sTempString = TextFromSmartArtNode(oShp.SmartArt.Nodes, 0)
If Len(sTempString) > 0 Then
Print #iFile, sTempString
End If
End If
End If ' msoPlaceholder
End If ' Has text frame/Has text
Next oShp
Print #iFile, vbCrLf
Next i
Close #iFile
'MsgBox "文件已创建在 '" & oPres.Path & PathSep & "AllText.txt'"
MsgBox "文件已创建在 '" & oPres.Path & PathSep & oPres.Name & ".txt'"
End Sub
Function TextFromGroupShape(oSh As Shape) As String
' Returns the text from the shapes in a group
' and
' recursively, text within shapes within groups within groups etc.
Dim oGpSh As Shape
Dim sTempText As String
If oSh.Type = msoGroup Then
For Each oGpSh In oSh.GroupItems
With oGpSh
If .Type = msoGroup Then
sTempText = sTempText & TextFromGroupShape(oGpSh)
Else
If .HasTextFrame Then
If .TextFrame.HasText Then
sTempText = sTempText & " (Gp:) " & .TextFrame.TextRange.Text & vbCrLf
End If
End If
End If
End With
Next
End If
TextFromGroupShape = sTempText
End Function
Function TextFromSmartArtNode(oSh As SmartArtNodes, depth As Long) As String
' Returns the text from the shapes in a SmartArt shape recursively
Dim sTempText As String
Dim i As Long
For i = 1 To oSh.Count
With oSh(i)
If .TextFrame2.TextRange.Text <> "" Then
If depth = 0 Then
sTempText = sTempText & " (SmartArt:)" & .TextFrame2.TextRange & vbCrLf
Else
sTempText = sTempText & Space(depth * 4) & .TextFrame2.TextRange & vbCrLf
End If
sTempText = sTempText & TextFromSmartArtNode(.Nodes, depth + 1)
End If
End With
Next i
TextFromSmartArtNode = sTempText
End Function
