J'aime 0
Fork 0

Dernière activité 8 months ago

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

Convert PPT TXT VBA

LiuShen's Avatar LiuShen a révisé ce gist 8 months ago. Aller à la révision

Aucun changement

LiuShen's Avatar LiuShen a révisé ce gist 8 months ago. Aller à la révision

1 file changed, 185 insertions

main.bas(fichier créé)

@@ -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 +
Plus récent Plus ancien

Propulsé par Opengist ⋅ Load: 21ms⋅

Français
⋅ 个人主页 ⋅ 站长博客