LiuShen a révisé ce gist . Aller à la révision
Aucun changement
LiuShen a révisé ce gist . 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