1 | VERSION 5.00
|
---|
2 | Begin VB.Form Form1
|
---|
3 | Caption = "Form1"
|
---|
4 | ClientHeight = 1380
|
---|
5 | ClientLeft = 60
|
---|
6 | ClientTop = 450
|
---|
7 | ClientWidth = 3825
|
---|
8 | LinkTopic = "Form1"
|
---|
9 | ScaleHeight = 1380
|
---|
10 | ScaleWidth = 3825
|
---|
11 | StartUpPosition = 3 'Windows Default
|
---|
12 | Begin VB.Label W
|
---|
13 | Alignment = 2 'Center
|
---|
14 | Caption = "Word to HTML"
|
---|
15 | BeginProperty Font
|
---|
16 | Name = "MS Sans Serif"
|
---|
17 | Size = 24
|
---|
18 | Charset = 0
|
---|
19 | Weight = 400
|
---|
20 | Underline = 0 'False
|
---|
21 | Italic = 0 'False
|
---|
22 | Strikethrough = 0 'False
|
---|
23 | EndProperty
|
---|
24 | Height = 615
|
---|
25 | Left = 360
|
---|
26 | TabIndex = 0
|
---|
27 | Top = 360
|
---|
28 | Width = 3375
|
---|
29 | End
|
---|
30 | End
|
---|
31 | Attribute VB_Name = "Form1"
|
---|
32 | Attribute VB_GlobalNameSpace = False
|
---|
33 | Attribute VB_Creatable = False
|
---|
34 | Attribute VB_PredeclaredId = True
|
---|
35 | Attribute VB_Exposed = False
|
---|
36 | Private Sub Form_Load()
|
---|
37 | 'For solving the backward compatability of MS Automation with VB script
|
---|
38 | 'We need to use the late binding technique, in which mean that we need to
|
---|
39 | 'define all Office Automation variable as an Object first and it can then
|
---|
40 | 'to decide the office version at run-tim.
|
---|
41 | Dim objPA As Object
|
---|
42 | Set objPA = CreateObject("PowerPoint.Application")
|
---|
43 | objPA.Visible = True
|
---|
44 |
|
---|
45 | Dim objPPTs As Object
|
---|
46 | Set objPPTs = objPA.Presentations
|
---|
47 |
|
---|
48 | htm = False
|
---|
49 | jpg = False
|
---|
50 | gif = False
|
---|
51 | old = False
|
---|
52 | png = False
|
---|
53 | meta = False
|
---|
54 |
|
---|
55 | 'cmdln = "-g " & Chr(34) & "H:\chi\gsdl\collect\PPTTest\import\LITA-2004.ppt" & Chr(34) & Chr(34) & "H:\chi\gsdl\collect\PPTTest\tmp\LITA-2004" & Chr(34)
|
---|
56 | cmdln = LCase(Command())
|
---|
57 | 'MsgBox ("Command:" + cmdln)
|
---|
58 | 'cmdln = "-g H:\chi\Visual Basic\ForumPres270404.ppt H:\chi\Visual Basic\tmp\ForumPres270404"
|
---|
59 | outputdir = getoutput(cmdln)
|
---|
60 | File = Left(cmdln, InStr(cmdln, ".ppt") + 3)
|
---|
61 | item_file = Left(cmdln, InStr(cmdln, ".ppt"))
|
---|
62 | args = getargs(File)
|
---|
63 | direc = getdir(File)
|
---|
64 | File = getfile(File)
|
---|
65 |
|
---|
66 | item_file = getfile(item_file)
|
---|
67 | 'We don't use this script to convert the PPT to html, instead, we use
|
---|
68 | 'the open source come with Greenstone package
|
---|
69 | If InStr(args, "j") Then jpg = True
|
---|
70 | If InStr(args, "g") Then gif = True
|
---|
71 | If InStr(args, "p") Then png = True
|
---|
72 |
|
---|
73 | Dim item, text As Object
|
---|
74 | Dim fso As Object
|
---|
75 | Set fso = CreateObject("Scripting.FileSystemObject")
|
---|
76 |
|
---|
77 | 'Modified for apply to GSII environment setting
|
---|
78 | output_tmp = Left(outputdir, InStr(outputdir, "\tmp") + 3)
|
---|
79 | 'output_tmp = Mid(outputdir, 2, InStr(outputdir, "\tmp") + 3)
|
---|
80 | 'MsgBox ("OUTPUT_TMP:" + output_tmp)
|
---|
81 |
|
---|
82 | If Not fso.FolderExists(output_tmp) Then
|
---|
83 | fso.CreateFolder (output_tmp)
|
---|
84 | If Not fso.FolderExists(outputdir) Then
|
---|
85 | fso.CreateFolder (outputdir)
|
---|
86 | End If
|
---|
87 | Else
|
---|
88 | If Not fso.FolderExists(outputdir) Then
|
---|
89 | fso.CreateFolder (outputdir)
|
---|
90 | End If
|
---|
91 | End If
|
---|
92 |
|
---|
93 | 'generate document_name.item file
|
---|
94 | Set item = fso.CreateTextFile(outputdir + "\" + item_file + "item", ForWriting, True)
|
---|
95 | 'Set item = CreateObject("ADODB.Stream")
|
---|
96 | 'item.Open
|
---|
97 | 'item.Position = 0
|
---|
98 | 'item.Charset = "UTF-8"
|
---|
99 |
|
---|
100 | 'Print #3, "<?xml version=" + Chr(34) + "1.0" + Chr(34) + " encoding=" + Chr(34) + "UTF-8" + Chr(34) + " standalone=" + Chr(34) + "no" + Chr(34) + "?>"
|
---|
101 | 'Print #3, "<!DOCTYPE DirectoryMetadata SYSTEM " + Chr(34) + "http://greenstone.org/dtd/DirectoryMetadata/1.0/DirectoryMetadata.dtd" + Chr(34) + ">"
|
---|
102 | 'Print #1, "<PagedDocument>"
|
---|
103 | item.WriteLine ("<PagedDocument>")
|
---|
104 | 'item.WriteText "<PagedDocument>", 1
|
---|
105 | Source = direc + File
|
---|
106 | 'MsgBox ("Src:" + Source)
|
---|
107 | objPPTs.Open (Source)
|
---|
108 |
|
---|
109 | 'do stuff
|
---|
110 | n = 1
|
---|
111 | Dim slide_shape As Shape
|
---|
112 | j = 2
|
---|
113 | For slide_count = 1 To objPPTs(1).Slides.Count
|
---|
114 | current_slide = objPPTs(1).Slides(slide_count).Name
|
---|
115 | 'generate a text version
|
---|
116 | Set text = fso.CreateTextFile(outputdir + "\Slide" + CStr(slide_count) + ".txt", ForWriting, True)
|
---|
117 | If (objPPTs(1).Slides(slide_count).Shapes.HasTitle) Then
|
---|
118 | slide_title = objPPTs(1).Slides(slide_count).Shapes.Title.TextFrame.TextRange
|
---|
119 | Else
|
---|
120 | slide_title = objPPTs(1).Slides(slide_count).Name
|
---|
121 | End If
|
---|
122 | slide_text = ""
|
---|
123 | found_text = True
|
---|
124 | For iShape = 1 To objPPTs(1).Slides(slide_count).Shapes.Count
|
---|
125 | If (objPPTs(1).Slides(slide_count).Shapes(iShape).TextFrame.HasText) Then
|
---|
126 | slide_text = objPPTs(1).Slides(slide_count).Shapes(iShape).TextFrame.TextRange.text
|
---|
127 | 'MsgBox ("Slide_text:" + slide_text)
|
---|
128 | If slide_text <> "" Then
|
---|
129 | text.WriteLine (slide_text)
|
---|
130 | 'text.WriteText (slide_text)
|
---|
131 | Else
|
---|
132 | text.WriteLine ("This slide has no text")
|
---|
133 | End If
|
---|
134 | End If
|
---|
135 | Next iShape
|
---|
136 | 'text_file = outputdir + "\Slide" + CStr(slide_count) + ".txt"
|
---|
137 | 'text.SaveToFile text_file
|
---|
138 | 'text.Close
|
---|
139 | 'j = j + 1
|
---|
140 | If objPPTs(1).Slides.Count >= 1 And slide_count < objPPTs(1).Slides.Count Then
|
---|
141 | next_slide = objPPTs(1).Slides(slide_count + 1).Name
|
---|
142 | Else
|
---|
143 | nextf = " "
|
---|
144 | End If
|
---|
145 | If htm Then
|
---|
146 | 'Not developed for converting to html yet
|
---|
147 | 'Currently, if the user choose to convert the PPT to the html file
|
---|
148 | 'We will only allow users to use the open source method through Greenstone
|
---|
149 | End If
|
---|
150 | If gif Then
|
---|
151 | current_slide = "Slide" + CStr(n)
|
---|
152 | If nextf <> " " Then
|
---|
153 | nextf = outputdir + "\" + "Slide" + CStr(n + 1)
|
---|
154 | End If
|
---|
155 | prevhtml = outputdir + "\" + current_slide + ".gif"
|
---|
156 | If slide_text = "" Then
|
---|
157 | itemxml item, current_slide + ".gif", "", n, slide_title
|
---|
158 | Else
|
---|
159 | itemxml item, current_slide + ".gif", current_slide + ".txt", n, slide_title
|
---|
160 | End If
|
---|
161 | End If
|
---|
162 | If jpg Then
|
---|
163 | current_slide = "Slide" + CStr(n)
|
---|
164 | If nextf <> " " Then
|
---|
165 | nextf = outputdir + "\" + "Slide" + CStr(n + 1)
|
---|
166 | End If
|
---|
167 | prevhtml = outputdir + "\" + current_slide + ".jpg"
|
---|
168 | If slide_text = "" Then
|
---|
169 | itemxml item, current_slide + ".jpg", "", n, slide_title
|
---|
170 | Else
|
---|
171 | itemxml item, current_slide + ".jpg", current_slide + ".txt", n, slide_title
|
---|
172 | End If
|
---|
173 | End If
|
---|
174 | If png Then
|
---|
175 | current_slide = "Slide" + CStr(n)
|
---|
176 | If nextf <> " " Then
|
---|
177 | nextf = outputdir + "\" + "Slide" + CStr(n + 1)
|
---|
178 | End If
|
---|
179 | prevhtml = outputdir + "\" + current_slide + ".png"
|
---|
180 | If slide_text = "" Then
|
---|
181 | itemxml item, current_slide + ".png", "", n, slide_title
|
---|
182 | Else
|
---|
183 | itemxml item, current_slide + ".png", current_slide + ".txt", n, slide_title
|
---|
184 | End If
|
---|
185 | End If
|
---|
186 | n = n + 1
|
---|
187 | item.WriteLine (" </Page>")
|
---|
188 | 'item.WriteText " </Page>", 1
|
---|
189 | Next
|
---|
190 | i = 0
|
---|
191 | If htm Then
|
---|
192 | 'ppts(1).SaveAs outputdir, ppSaveAsHTMLv3
|
---|
193 | ElseIf gif Then
|
---|
194 | objPPTs(1).SaveAs outputdir, ppSaveAsGIF
|
---|
195 | ElseIf jpg Then
|
---|
196 | objPPTs(1).SaveAs outputdir, ppSaveAsJPG
|
---|
197 | ElseIf png Then
|
---|
198 | objPPTs(1).SaveAs outputdir, ppSaveAsPNG
|
---|
199 | End If
|
---|
200 |
|
---|
201 | item.WriteLine ("</PagedDocument>")
|
---|
202 | 'item.WriteText "</PagedDocument>", 1
|
---|
203 | 'objStream.SaveToFile pstrFile
|
---|
204 | 'item.SaveToFile outputdir + "\" + item_file + "item"
|
---|
205 | item.Close
|
---|
206 | objPPTs(1).Close
|
---|
207 | Set fso = Nothing
|
---|
208 | Set text = Nothing
|
---|
209 | Set item = Nothing
|
---|
210 | objPA.Quit
|
---|
211 | End
|
---|
212 | End Sub
|
---|
213 | Function getoutput(line)
|
---|
214 | cmdln = line
|
---|
215 | While InStr(cmdln, ".ppt")
|
---|
216 | cmdln = Trim(Right(cmdln, Len(cmdln) - (InStr(cmdln, ".ppt") + 4)))
|
---|
217 | cmdln = Trim(Mid(cmdln, 2, Len(cmdln) - 2))
|
---|
218 | Wend
|
---|
219 | getoutput = cmdln
|
---|
220 | End Function
|
---|
221 | Function getargs(line)
|
---|
222 | x = LTrim(line)
|
---|
223 | If InStr(x, "-") = 1 Then
|
---|
224 | getargs = Left(line, InStr(line, " "))
|
---|
225 | End If
|
---|
226 | End Function
|
---|
227 | Function getdir(line)
|
---|
228 | x = LTrim(Right(line, Len(line) - Len(getargs(line)) - 1))
|
---|
229 | If InStr(x, ":") <> 2 Then
|
---|
230 | direc = CurDir
|
---|
231 | If Right(direc, 1) <> "\" Then direc = direc + "\"
|
---|
232 | End If
|
---|
233 |
|
---|
234 | While InStr(x, "\")
|
---|
235 | direc = direc + Left(x, InStr(x, "\"))
|
---|
236 | x = Right(x, Len(x) - InStr(x, "\"))
|
---|
237 | Wend
|
---|
238 | getdir = direc
|
---|
239 | End Function
|
---|
240 | Function getfile(line)
|
---|
241 | x = LTrim(Right(line, Len(line) - Len(getargs(line))))
|
---|
242 | While InStr(x, "\")
|
---|
243 | x = Right(x, Len(x) - InStr(x, "\"))
|
---|
244 | Wend
|
---|
245 | getfile = x
|
---|
246 | End Function
|
---|
247 | Sub itemxml(out_item, thisfile, txtfile, num, slide_title)
|
---|
248 | out_item.WriteLine (" <Page pagenum=" + Chr(34) + CStr(num) + Chr(34) + " imgfile=" + Chr(34) + thisfile + Chr(34) + " txtfile=" + Chr(34) + txtfile + Chr(34) + ">")
|
---|
249 | 'out_item.WriteText " <Page pagenum=" + Chr(34) + CStr(num) + Chr(34) + " imgfile=" + Chr(34) + thisfile + Chr(34) + " txtfile=" + Chr(34) + txtfile + Chr(34) + ">", 1
|
---|
250 | If slide_title <> "" Then
|
---|
251 | out_item.WriteLine (" <Metadata name=" + Chr(34) + "Title" + Chr(34) + ">" + slide_title + "</Metadata>")
|
---|
252 | 'MsgBox ("Title:" + slide_title)
|
---|
253 | 'out_item.WriteText " <Metadata name=" + Chr(34) + "Title" + Chr(34) + ">" + slide_title + "</Metadata>", 1
|
---|
254 | End If
|
---|
255 | End Sub
|
---|
256 | Function checknext(filename, extention)
|
---|
257 | If filename = "" Then
|
---|
258 | checknext = ""
|
---|
259 | Else
|
---|
260 | checknext = filename + extention
|
---|
261 | End If
|
---|
262 | End Function
|
---|
263 | Function replaceStrings(f, c, W)
|
---|
264 | s = f
|
---|
265 | t = ""
|
---|
266 | While InStr(s, c)
|
---|
267 | t = t + Left(s, InStr(s, c) - 1) + W
|
---|
268 | s = Right(s, Len(s) - (InStr(s, c) + Len(c)) + 1)
|
---|
269 | Wend
|
---|
270 | replaceStrings = t + s
|
---|
271 | End Function
|
---|
272 | Function fixnum(s)
|
---|
273 | fixnum = String(4 - Len(s), "0") + s
|
---|
274 | End Function
|
---|