我成立以下宏代码用于将 PowerPoint 文件转换为文本文件:
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
For Each oSld In oSlides 'Loop thru each slide
' Include the slide number (the number that will appear in slide's
' page number placeholder; you could also use SlideIndex
' for the ordinal number of the slide in the file
Print #iFile, "Slide:" & vbTab & cstr(oSld.SlideNumber)
For Each oShp In oSld.Shapes 'Loop thru each shape on slide
'Check to see if shape has a text frame and text
If oShp.HasTextFrame And oShp.TextFrame.HasText Then
If oShp.Type = msoPlaceholder Then
Select Case oShp.PlaceholderFormat.Type
Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
Print #iFile, "Title:" & vbTab & oShp.TextFrame.TextRange
Case Is = ppPlaceholderBody
Print #iFile, "Body:" & vbTab & oShp.TextFrame.TextRange
Case Is = ppPlaceholderSubtitle
Print #iFile, "SubTitle:" & vbTab & oShp.TextFrame.TextRange
Case Else
Print #iFile, "Other Placeholder:" & vbTab & oShp.TextFrame.TextRange
End Select
Else
Print #iFile, vbTab & oShp.TextFrame.TextRange
End If ' msoPlaceholder
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
End If
End If ' Has text frame/Has text
Next oShp
Next oSld
'Close output file
Close #iFile
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
NormalExit:
Exit Function
Errorhandler:
Resume Next
End Function
但它不适用于复杂文本,例如阿拉伯语文本。我需要从可包含复杂文本的 PowerPoint 文件创建 Unicode 文本文件。我该如何修改上述代码来实现这一点?
答案1
我可以修复这个问题:
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
Set fsObject = CreateObject("Scripting.FileSystemObject")
Set xmlFile = fsObject.CreateTextFile(oPres.Path & PathSep & "AllText.txt", True, True) 'the second "true" forces a unicode file.
For Each oSld In oSlides 'Loop thru each slide
' Include the slide number (the number that will appear in slide's
' page number placeholder; you could also use SlideIndex
' for the ordinal number of the slide in the file
xmlFile.writeline "Slide:" & vbTab & CStr(oSld.SlideNumber)
For Each oShp In oSld.Shapes 'Loop thru each shape on slide
'Check to see if shape has a text frame and text
If oShp.HasTextFrame And oShp.TextFrame.HasText Then
If oShp.Type = msoPlaceholder Then
Select Case oShp.PlaceholderFormat.Type
Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
xmlFile.writeline "Title:" & vbTab & oShp.TextFrame.TextRange
Case Is = ppPlaceholderBody
xmlFile.writeline "Body:" & vbTab & oShp.TextFrame.TextRange
Case Is = ppPlaceholderSubtitle
xmlFile.writeline "SubTitle:" & vbTab & oShp.TextFrame.TextRange
Case Else
xmlFile.writeline "Other Placeholder:" & vbTab & oShp.TextFrame.TextRange
End Select
Else
xmlFile.writeline vbTab & oShp.TextFrame.TextRange
End If ' msoPlaceholder
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
xmlFile.writeline sTempString
End If
End If
End If ' Has text frame/Has text
Next oShp
Next oSld
'Close output file
xmlFile.Close
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
NormalExit:
Exit Function
Errorhandler:
Resume Next
End Function
但您可能需要使用记事本打开 AllText.txt 文件,然后以所需的 Unicode 格式再次保存它。