MartyConnelly
martyconnelly at shaw.ca
Fri Feb 6 12:43:03 CST 2004
This might get you started but constants vary for each version of Word
This worked for 2000.
Also it generates a lot of excess html
see for other methods or use word macro recorder to see code generated
by SaveAs HTML
http://word.mvps.org/FAQs/General/SaveAsWebWithoutXML.htm
Public Sub ConvertWordToHTML(strPath, strDocName)
On Error Resume Next
Dim lenDocname As Integer
Dim intStart As Integer
Dim bolStarted As Boolean
Dim newDocName As String
Dim oldDocName As String
Dim strContents As String
Dim WordApp As Word.Application
Dim wordDoc As Word.Document
Dim noneDoc As Word.Document
Set noneDoc = Nothing
Set WordApp = GetObject(, "Word.Application")
If Err <> 0 Then
'word wasn't running, start it from code
Set WordApp = CreateObject("Word.Application")
End If
'get old document name
oldDocName = Trim(strDocName)
' get length
lenDocname = Len(Trim(strDocName))
'remove last 4 characters and replace with .htm extension
newDocName = Left(Trim(strDocName), lenDocname - 4) & ".htm"
'delete new file just in case
strContents = strPath & newDocName
'Kill (strContents)
'open and display document
strContents = strPath & oldDocName
Set wordDoc = Documents.Open(FileName:=strContents, _
ConfirmConversions:=False, _
ReadOnly:=False, _
AddToRecentFiles:=False, _
Revert:=False, _
Format:=wdOpenFormatAuto)
' Visible:=True)
' Format:=wdDocument,
' no idea why but i sometimes get err 53 file not found yet the file
still opens
If Err <> 0 And Err <> 53 Then
GoTo Quit_Conversion
End If
Err.Clear
'save as html
wordDoc.SaveAs FileName:=strPath & newDocName, _
FileFormat:=wdFormatHTML, _
LockComments:=False, _
Password:="", _
AddToRecentFiles:=False, _
WritePassword:="", _
ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, _
SaveFormsData:=False, _
SaveAsAOCELetter:=False
If Err <> 0 Then
GoTo Quit_Conversion
End If
Debug.Print newDocName
'cmdConvert.Enabled = False
'cmdConvert.Visible = False
Debug.print "Document Converted successfully"
Quit_Conversion:
If Err <> 0 Then
Debug.Print Err.Number & " " & Err.Description _
& ", " & Err.Source, "e"
End If
If wordDoc <> noneDoc Then
wordDoc.Close SaveChanges:=False
End If
Set wordDoc = Nothing
If bolStarted = True Then
WordApp.Quit
End If
Set WordApp = Nothing
End Sub
Bryan Carbonnell wrote:
>>From: "Terri Jarus" <jarus at amerinet-gpo.com>
>>Date: Fri, 06 Feb 2004 07:54:39 -0600
>>To: <accessd-owner at databaseadvisors.com>
>>Subject: [AccessD] AXP - Create HTML Document
>>
>>I have a report that is created dynamically in Word, however, we now want it to be created in HTML.
>>
>>Does anyone have sample code to do something like this?
>>
>>Here is a sample (shortened version) of what we use for the Word doc - how can I change it to HTML. Or is there a better way?
>>
>>Private Sub CreateCDS_Click()
>>DoCmd.Save
>> Dim objWord As Word.Application
>> Dim filename As String
>>
>> Set objWord = New Word.Application
>>
>> filename = "U:\Suppliers\Reports\Contract Sales\EForm\cds.dot"
>>
>> With objWord
>>
>> On Error GoTo MsgInfo
>> .Visible = True
>>
>> .Documents.Add _
>> Template:=filename, _
>> NewTemplate:=False
>>
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="ContractNumber"
>>
>> .Selection.TypeText _
>> Text:=ContractNumber
>>
>> If HubSupplier <> "" Then
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="Hub"
>>
>> .Selection.TypeText _
>> Text:="Hub Supplier: " & Nz([HubSupplier])
>> Else
>> End If
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="ContUpd"
>>
>> .Selection.TypeText _
>> Text:=ContUpd
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="InternalNum"
>>
>> .Selection.TypeText _
>> Text:=Nz([VendorInternal])
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="PDU"
>>
>> .Selection.TypeText _
>> Text:=Prog
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="Category"
>>
>> .Selection.TypeText _
>> Text:=IndexCategory
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="SupplierName"
>>
>> .Selection.TypeText _
>> Text:=UCase([SupplierPrintName])
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="Address1"
>>
>> .Selection.TypeText _
>> Text:=SupplierAddress1
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="Address2"
>>
>> .Selection.TypeText _
>> Text:=Nz([SupplierAddress2])
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="CityStateZip"
>>
>> .Selection.TypeText _
>> Text:=CityStateZip
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="Phone"
>>
>> .Selection.TypeText _
>> Text:=Nz([SupplierPhone])
>>
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="Fax"
>>
>> If Nz(SupplierFax, "") = "" Then
>> .Selection.Expand wdWord
>> .Selection.Delete
>> Else
>>
>> .Selection.TypeText _
>> Text:="FAX: " & Nz([SupplierFax])
>>
>> End If
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="TollFree"
>>
>> If Nz(SupplierTollFree, "") = "" Then
>> .Selection.Expand wdParagraph
>> .Selection.Delete
>> Else
>>
>> .Selection.TypeText _
>> Text:="TOLL FREE: " & Nz([SupplierTollFree])
>>
>> End If
>>
>> .Selection.GoTo _
>> What:=wdGoToBookmark, _
>> Name:="WebAddress"
>>
>> .Selection.TypeText _
>> Text:="Website: " & Nz([VendorWeb])
>>
>> objWord.Selection.TypeParagraph
>> objWord.Selection.MoveDown Unit:=wdLine
>>
>>
>> .Quit
>>
>> End With
>>
>> Set objWord = Nothing
>>
>>MsgInfo:
>> On Error Resume Next
>> 'MsgBox "There is a required field missing information, please recheck your CDS data. Enter any required data into the Contract Info database."
>> Exit Sub
>>End Sub
>>
>>Please advise.
>>
>>Thanks for any help.
>>
>>
>>Terri Jarus
>>Director, Contract Support Services
>>jarus at amerinet-gpo.com
>>314-542-1902
>>
>>
>>---------------------------------------------------------------------------
>>This email and any files transmitted with it are confidential and
>>intended solely for the use of the individuals or entities to whom they
>>are addressed. If you have received this email in error please return
>>it to the sender, and erase any copies thereof.
>>Copyright 2004 Amerinet 1nc.
>>
>>
>>
>
>--
>Bryan Carbonnell - carbonnb at sympatico.ca
>Unfortunately common sense isn't so common!
>
>_______________________________________________
>AccessD mailing list
>AccessD at databaseadvisors.com
>http://databaseadvisors.com/mailman/listinfo/accessd
>Website: http://www.databaseadvisors.com
>
>
>
--
Marty Connelly
Victoria, B.C.
Canada