root/trunk/winbin/bin/pptextract.frm @ 10628

Revision 10628, 9.8 KB (checked in by chi, 15 years ago)

Modify VB script to use late binding technique to solve the problem of running the script for
Multiple Office versions.

  • Property svn:keywords set to Author Date Id Revision
Line 
1VERSION 5.00
2Begin 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
30End
31Attribute VB_Name = "Form1"
32Attribute VB_GlobalNameSpace = False
33Attribute VB_Creatable = False
34Attribute VB_PredeclaredId = True
35Attribute VB_Exposed = False
36Private 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
211End
212End Sub
213Function 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
221Function getargs(line)
222    x = LTrim(line)
223    If InStr(x, "-") = 1 Then
224        getargs = Left(line, InStr(line, " "))
225    End If
226End Function
227Function 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
239End Function
240Function 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
246End Function
247Sub 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
256Function checknext(filename, extention)
257    If filename = "" Then
258        checknext = ""
259    Else
260        checknext = filename + extention
261    End If
262End Function
263Function replaceStrings(f, c, W)
264s = f
265t = ""
266While 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)
269Wend
270replaceStrings = t + s
271End Function
272Function fixnum(s)
273    fixnum = String(4 - Len(s), "0") + s
274End Function
Note: See TracBrowser for help on using the browser.