Like 0
Fork 0

Last active 10 months ago

利用visual basic将PPT中的所有文本提取出来

Convert PPT TXT VBA

LiuShen's Avatar LiuShen revised this gist 10 months ago. Go to revision

No changes

LiuShen's Avatar LiuShen revised this gist 10 months ago. Go to revision

1 file changed, 185 insertions

main.bas(file created)

@@ -0,0 +1,185 @@
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 +
Newer Older

Powered by Opengist ⋅ Load: 27ms⋅

English
⋅ 个人主页 ⋅ 站长博客