Logo 
Search:

MS Office Forum

Ask Question   UnAnswered
Home » Forum » MS Office       RSS Feeds

Convert Excel VBA procedure to a VB Script procedure that runs

  Asked By: Don    Date: Mar 15    Category: MS Office    Views: 1839
  

I really hope someone can help me finish this demonstration!
Can anyone pls create some HTML web page code, which will run the
following VBA procedure named ConvertWordToXMLandHTML, when a
command button or a filefield ActiveX Browse object is clicked.

I am not good at writing HTML code and am not experienced with VB
Script either.
I think that my VBA procedure will have to be converted to VB Script?

I wrote this VBA procedure in Excel's VB Editor and it runs OK.
It parses a Word document by checking each of its paragraphs and
puts that data into a text file, which ends up being an XML data
file named Parent.xml. A second text file is created called
Parent.html, which is displays the data in Parent.xml using a XSL
Transformation stylesheet named Stylesheet.xsl

I will have to send you two files, ie the Word document file named
Parenting and Gobble.doc, as well as the XSL Transformation
stylesheet file, Stylesheet.xsl

Here is the ConvertWordToXMLandHTML sub procedure code.
Sub ConvertWordToXMLandHTML()
Dim objWordApp
Dim objWordDoc 'is Word document to convert
Dim objTextDoc 'will become ?.xml data file
Dim objHTMLdoc 'will be the HTML file to display output in IE 6
Dim rngTarget
Dim strPath
Dim strFileNameOnly


strPath = ThisWorkbook.Path & "\"
ChDir strPath

'CREATE THE XML file.
Set objWordApp = CreateObject("Word.Application")
objWordApp.Visible = True

'Open Doc to convert.
Set objWordDoc = GetObject(strPath & "Parenting and
Gobble.doc", "Word.Document")
strFileNameOnly = objWordDoc.Name
strFileNameOnly = Left(strFileNameOnly, InStr(1,
strFileNameOnly, " ", 1) - 1)
Debug.Print strFileNameOnly

'Create the XML file and add the processing instruction.
Set objTextDoc = objWordApp.Documents.Add
Set rngTarget = objTextDoc.Content

With rngTarget 'This is very illogically set up
'in the Word document!
.Style = "Normal"
.Style.Font.Size = 10

.Text = "<?xml version='1.0'?>"
.InsertParagraphAfter
.Collapse wdCollapseEnd 'Move cursor to end of range.
.Text = "<Parenting-and-gobble>" 'Root element start name tag
.InsertParagraphAfter
.InsertParagraphAfter
.Collapse wdCollapseEnd
.Text = "<Topic>Parenting-and-Gobble</Topic>"
.InsertParagraphAfter
.Collapse wdCollapseEnd

'Loop thru the Word doc's paragraphs to find text + add to XML file.
For Each para In objWordDoc.Content.Paragraphs

Select Case para.Style
Case "Title", "Subtitle", "Heading 1", "Body Text"
.Text = vbTab & "<Parenting>" & para.Range.Text
& "</Parenting>"
.InsertParagraphAfter
.Collapse wdCollapseEnd

Case "List Bullet 2"
.Text = vbTab & vbTab & "<Stage>" &
para.Range.Text & "</Stage>"
.InsertParagraphAfter
.Collapse wdCollapseEnd

Case "Family1"
.Text = vbTab & "<Family>"
.InsertParagraphAfter
.Collapse wdCollapseEnd

Case "Family2"
.Text = vbTab & "</Family>"
.InsertParagraphAfter
.Collapse wdCollapseEnd

Case Else
.Text = vbTab & "<Gobble>" & para.Range.Text
& "</Gobble>"
.InsertParagraphAfter
.Collapse wdCollapseEnd
End Select

Next para

'Clean up manual page breaks in XML file.
With objTextDoc.Content.Find
.ClearFormatting
.Text = "&"
With .Replacement
.ClearFormatting
.Text = "&"
End With
.Execute Format:=False, Replace:=wdReplaceAll
End With

'Add final root element tag.
.SetRange Start:=objTextDoc.Content.Start,
End:=objTextDoc.Content.End
.InsertParagraphAfter
.Collapse wdCollapseEnd

.Text = "</Parenting-and-gobble>"

End With


'Save the XML file as a text file, with a .xml extension.
' saving as a text file should remove any manual page breaks
line breaks.
objTextDoc.SaveAs Filename:=strPath & strFileNameOnly & ".xml",
FileFormat:=wdFormatText
objTextDoc.Close
Set objTextDoc = Nothing

'Close and clean up Word document that was converted.
objWordDoc.Close
Set objWordDoc = Nothing

'CREATE THE HTML file
' Chr$(13) = a carriage return
' Chr$(34) = a double-quote

Set objHTMLdoc = objWordApp.Documents.Add
Set rngTarget = objHTMLdoc.Content

'The following code adds the text which properly displays the HTML
page.
' Note: that strFileNameOnly correctly names this matching HTML
file, so that
' both the XML file and the HTML file have the same filename,
' but different file extensions.
rngTarget.Text = _
"<HTML>" & Chr$(13) & _
"<BODY>" & Chr$(13) & _
"<DIV ID=" & Chr$(34) & "show" & Chr$(34) & "></DIV>" & Chr$(13) & _
"<XML ID=" & Chr$(34) & "style" & Chr$(34) & " SRC=" & Chr$(34)
& "Stylesheet.xsl" & Chr$(34) & "></XML>" & Chr$(13) & _
"<!-- HTML page using MS XML Data Islands -->" & Chr$(13) & _
"<SCRIPT>" & Chr$(13) & _
"function showData(){" & Chr$(13) & _
"if (xml.readyState == " & Chr$(34) & "complete" & Chr$(34) & ")
{" & Chr$(13) & _
"show.innerHTML = xml.transformNode(style.documentElement);" &
Chr$(13) & _
"}" & Chr$(13) & _
"}" & Chr$(13) & _
Chr$(13) & _
"document.writeln('" & Chr$(34) & "<XML ID=" & Chr$(34) & "xml" &
Chr$(34) & " SRC=" & strFileNameOnly & ".xml onreadystatechange=" &
Chr$(34) & "showData()" & Chr$(34) & "></XML>');" & Chr$(13) & _
"</SCRIPT>" & Chr$(13) & _
Chr$(13) & _
"</BODY>" & Chr$(13) & _
"</HTML>"

objHTMLdoc.SaveAs Filename:=strPath & strFileNameOnly & ".html",
FileFormat:=wdFormatText
objHTMLdoc.Close

'Clean up objects
'Set objHTMLdoc = Nothing
'Set rngTarget = Nothing

'objWordApp.Quit
'Set objWordApp = Nothing


End Sub

Share: 

 

No Answers Found. Be the First, To Post Answer.

 




Tagged: