1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
| 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
|
