LiuShen/快速提取所有ppt中的文本内容

main.bas · 5.7 KiB · QBasic Raw

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
  Dim fd() As String

#If Mac Then
    PathSep = "/"
  #Else
    PathSep = "\"
  #End If

fd = Split(FileDialogOpen, vbLf)
  If Left(fd(0), 1) = "-" Then
    Debug.Print "Canceled"
    Exit Sub
  End If

For n = LBound(fd) To UBound(fd)
    Set oPres = Presentations.Open(FileName:=fd(n), ReadOnly:=msoTrue, WithWindow:=msoTrue)
    Set oSlides = oPres.Slides

FileNum = FreeFile

'Open output file
    ' NOTE:  errors here if file hasn't been saved
    Open oPres.Path & PathSep & oPres.Name & ".txt" For Output As FileNum
    
    num_slides = oPres.Slides.Count

For i = 1 To num_slides
      Set oSld = oPres.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 = 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
            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
          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    ' Has text frame/Has text
      Next oShp
      
      Print #iFile, vbCrLf
    Next i
    Close #iFile
    oPres.Close
  Next n

MsgBox "已处理 " & UBound(fd) - LBound(fd) + 1 & " 个文件"
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

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
    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

Function FileDialogOpen() As String

#If Mac Then
    ' 默认路径
    mypath = MacScript("return (path to desktop folder) as String")

sMacScript = "set applescript's text item delimiters to "","" " & vbNewLine & _
    "try " & vbNewLine & _
    "set theFiles to (choose file of type {""ppt"", ""pptx""}" & _
    "with prompt ""请选择要处理的一个或多个 PowerPoint 文档"" default location alias """ & _
    mypath & """ multiple selections allowed true)" & vbNewLine & _
    "set applescript's text item delimiters to """" " & vbNewLine & _
    "on error errStr number errorNumber" & vbNewLine & _
    "return errorNumber " & vbNewLine & _
    "end try " & vbNewLine & _
    "repeat with i from 1 to length of theFiles" & vbNewLine & _
    "if i = 1 then" & vbNewLine & _
    "set fpath to POSIX path of item i of theFiles" & vbNewLine & _
    "else" & vbNewLine & _
    "set fpath to fpath & """ & vbNewLine & _
    """ & POSIX path of item i of theFiles" & vbNewLine & _
    "end if" & vbNewLine & _
    "end repeat" & vbNewLine & _
    "return fpath"

FileDialogOpen = MacScript(sMacScript)

#Else
    With Application.FileDialog(msoFileDialogOpen)
      .AllowMultiSelect = True
      .Title = "请选择要处理的一个或多个 PowerPoint 文档"
      .Filters.Add "PowerPoint 文档", "*.ppt; *.pptx", 1
      If .Show = -1 Then
        FileDialogOpen = ""
        For i = 1 To .SelectedItems.Count
          If i = 1 Then
            FileDialogOpen = .SelectedItems.Item(i)
          Else
            FileDialogOpen = FileDialogOpen & vbLf & .SelectedItems.Item(i)
          End If
        Next
      Else
        FileDialogOpen = "-"
      End If
    End With

#End If
End Function

1	Sub ExportText()
2	Dim oPres As Presentation
3	Dim oSlides As Slides
4	Dim oSld As Slide 'Slide Object
5	Dim oShp As Shape 'Shape Object
6	Dim iFile As Integer 'File handle for output
7	iFile = FreeFile 'Get a free file number
8	Dim PathSep As String
9	Dim FileNum As Integer
10	Dim sTempString As String
11	Dim fd() As String
12
13	#If Mac Then
14	PathSep = "/"
15	#Else
16	PathSep = "\"
17	#End If
18
19	fd = Split(FileDialogOpen, vbLf)
20	If Left(fd(0), 1) = "-" Then
21	Debug.Print "Canceled"
22	Exit Sub
23	End If
24
25	For n = LBound(fd) To UBound(fd)
26	Set oPres = Presentations.Open(FileName:=fd(n), ReadOnly:=msoTrue, WithWindow:=msoTrue)
27	Set oSlides = oPres.Slides
28
29	FileNum = FreeFile
30
31	'Open output file
32	' NOTE: errors here if file hasn't been saved
33	Open oPres.Path & PathSep & oPres.Name & ".txt" For Output As FileNum
34
35	num_slides = oPres.Slides.Count
36
37	For i = 1 To num_slides
38	Set oSld = oPres.Slides(i)
39	Print #iFile, "Slide:" & vbTab & CStr(oSld.SlideNumber)
40	For Each oShp In oSld.Shapes
41	'Check to see if shape has a text frame and text
42	If oShp.HasTextFrame And oShp.TextFrame.HasText Then
43	If oShp.Type = msoPlaceholder Then
44	Select Case oShp.PlaceholderFormat.Type
45	Case Is = ppPlaceholderTitle, ppPlaceholderCenterTitle
46	Print #iFile, "标题：" & vbTab & oShp.TextFrame.TextRange
47	Case Is = ppPlaceholderBody
48	Print #iFile, "正文：" & vbTab & oShp.TextFrame.TextRange
49	Case Is = ppPlaceholderSubtitle
50	Print #iFile, "副标题：" & vbTab & oShp.TextFrame.TextRange
51	Case Else
52	Print #iFile, "其他占位符：" & vbTab & oShp.TextFrame.TextRange
53	End Select
54	Else
55	Print #iFile, vbTab & oShp.TextFrame.TextRange
56	End If ' msoPlaceholder
57	Else ' it doesn't have a textframe - it might be a group that contains text so:
58	If oShp.Type = msoGroup Then
59	sTempString = TextFromGroupShape(oShp)
60	If Len(sTempString) > 0 Then
61	Print #iFile, sTempString
62	End If
63	ElseIf oShp.Type = msoSmartArt Then
64	sTempString = TextFromSmartArtNode(oShp.SmartArt.Nodes, 0)
65	If Len(sTempString) > 0 Then
66	Print #iFile, sTempString
67	End If
68	End If
69	End If ' Has text frame/Has text
70	Next oShp
71
72	Print #iFile, vbCrLf
73	Next i
74	Close #iFile
75	oPres.Close
76	Next n
77
78	MsgBox "已处理 " & UBound(fd) - LBound(fd) + 1 & " 个文件"
79	End Sub
80
81	Function TextFromGroupShape(oSh As Shape) As String
82	' Returns the text from the shapes in a group
83	' and recursively, text within shapes within groups within groups etc.
84
85	Dim oGpSh As Shape
86	Dim sTempText As String
87
88	If oSh.Type = msoGroup Then
89	For Each oGpSh In oSh.GroupItems
90	With oGpSh
91	If .Type = msoGroup Then
92	sTempText = sTempText & TextFromGroupShape(oGpSh)
93	Else
94	If .HasTextFrame Then
95	If .TextFrame.HasText Then
96	sTempText = sTempText & "(Gp:) " & .TextFrame.TextRange.Text & vbCrLf
97	End If
98	End If
99	End If
100	End With
101	Next
102	End If
103
104	TextFromGroupShape = sTempText
105
106	NormalExit:
107	Exit Function
108
109	Errorhandler:
110	Resume Next
111
112	End Function
113
114
115	Function TextFromSmartArtNode(oSh As SmartArtNodes, depth As Long) As String
116	' Returns the text from the shapes in a SmartArt shape recursively
117
118	Dim sTempText As String
119	For i = 1 To oSh.Count
120	With oSh(i)
121	If .TextFrame2.TextRange.Text <> "" Then
122	If depth = 0 Then
123	sTempText = sTempText & "(SmartArt:)" & .TextFrame2.TextRange & vbCrLf
124	Else
125	sTempText = sTempText & Space(depth * 4) & .TextFrame2.TextRange & vbCrLf
126	End If
127	sTempText = sTempText & TextFromSmartArtNode(.Nodes, depth + 1)
128	End If
129	End With
130	Next i
131
132	TextFromSmartArtNode = sTempText
133
134	End Function
135
136
137	Function FileDialogOpen() As String
138
139	#If Mac Then
140	' 默认路径
141	mypath = MacScript("return (path to desktop folder) as String")
142
143	sMacScript = "set applescript's text item delimiters to "","" " & vbNewLine & _
144	"try " & vbNewLine & _
145	"set theFiles to (choose file of type {""ppt"", ""pptx""}" & _
146	"with prompt ""请选择要处理的一个或多个 PowerPoint 文档"" default location alias """ & _
147	mypath & """ multiple selections allowed true)" & vbNewLine & _
148	"set applescript's text item delimiters to """" " & vbNewLine & _
149	"on error errStr number errorNumber" & vbNewLine & _
150	"return errorNumber " & vbNewLine & _
151	"end try " & vbNewLine & _
152	"repeat with i from 1 to length of theFiles" & vbNewLine & _
153	"if i = 1 then" & vbNewLine & _
154	"set fpath to POSIX path of item i of theFiles" & vbNewLine & _
155	"else" & vbNewLine & _
156	"set fpath to fpath & """ & vbNewLine & _
157	""" & POSIX path of item i of theFiles" & vbNewLine & _
158	"end if" & vbNewLine & _
159	"end repeat" & vbNewLine & _
160	"return fpath"
161
162	FileDialogOpen = MacScript(sMacScript)
163
164	#Else
165	With Application.FileDialog(msoFileDialogOpen)
166	.AllowMultiSelect = True
167	.Title = "请选择要处理的一个或多个 PowerPoint 文档"
168	.Filters.Add "PowerPoint 文档", ".ppt; .pptx", 1
169	If .Show = -1 Then
170	FileDialogOpen = ""
171	For i = 1 To .SelectedItems.Count
172	If i = 1 Then
173	FileDialogOpen = .SelectedItems.Item(i)
174	Else
175	FileDialogOpen = FileDialogOpen & vbLf & .SelectedItems.Item(i)
176	End If
177	Next
178	Else
179	FileDialogOpen = "-"
180	End If
181	End With
182
183	#End If
184	End Function
185
186