Sorry. Have you ever gotten html email with images in
it? In order to see the images the email system has to
link back to your system at teh time the user opens teh
email. All im trying to do is notify folks that the job
opportunity they inquired about is available now, so i
really dont need to send images just text. Also headers
and footers cause the same problems.
So the goal is to open a regular document, strip out
anything that woudl cause a link back reaction and then
save it as html. Html format is easiest for me to insert
text into and still maintain formatting.
Heres the code:
Private Sub cmdConvert_Click()
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 strPathTmp As String
Dim strContents As String
Dim WordApp As Word.Application
intStart = 0
Display_Message "Initiating Microsoft Word for
Conversion.", "w"
Do Until intStart > 20
intStart = intStart + 1
Display_Message "Initating Microsoft Word for
Conversion" & String(intStart, "."), "w"
Set WordApp = GetObject(, "Word.Application")
If Err = 0 Then
intStart = 99
Exit Do
End If
'word wasn't running, start it from code
Set WordApp = CreateObject("Word.Application")
If Err = 0 Then
intStart = 99
Exit Do
End If
Loop
If Err <> 0 Then
Display_Message "Unable to Initiate Word for
conversion", "e"
Exit Sub
Else
bolStarted = True
End If
' save old document path
strPathTmp = Options.DefaultFilePath(wdDocumentsPath)
'assign new document path
Options.DefaultFilePath(wdDocumentsPath) = Trim
(txtPath.Text)
'get old document name
oldDocName = Trim(txtDoc.Text)
' get length
lenDocname = Len(Trim(oldDocName))
'remove last 4 characters and replace with .htm extension
newDocName = Left(Trim(oldDocName), lenDocname - 4)
& ".htm"
'delete new file just in case
Kill (Trim(txtPath.Text) & newDocName)
'open and display document
WordApp.Documents.Open FileName:=Trim(Trim
(txtPath.Text) & oldDocName), _
ConfirmConversions:=False, _
ReadOnly:=False, _
revert:=False, _
addtorecentfiles:=False, _
Visible:=True
If Err <> 0 And Err <> 53 Then
Display_Message Err.Number & " " & Err.DESCRIPTION
& ", " & Err.Source, "e"
Options.DefaultFilePath(wdDocumentsPath) =
strPathTmp
Exit Sub
End If
Display_Message "Conversion in progress.........", "w"
WordApp.Documents(oldDocName).Activate
WordApp.ActiveWindow.ActivePane.Activate
'delete headers
WordApp.ActiveWindow.ActivePane.Activate
For intStart = 1 To 4 Step 1
Display_Message "Removing Headers in progress" &
String(intStart, "."), "w"
Select Case intStart
Case Is = 1
With
WordApp.ActiveWindow.ActivePane.View
.SeekView =
wdSeekCurrentPageHeader
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
Case Is = 2
With
WordApp.ActiveWindow.ActivePane.View
.SeekView = wdSeekPrimaryHeader
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
Case Is = 3
With
WordApp.ActiveWindow.ActivePane.View
.SeekView =
wdSeekEvenPagesHeader
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
Case Is = 4
With
WordApp.ActiveWindow.ActivePane.View
.SeekView =
wdSeekFirstPageHeader
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
End Select
Next intStart
' remove external objects
For intStart = ActiveDocument.InlineShapes.Count To 1
Step -1
Display_Message "Removing Images in progress" &
String(intStart, "."), "w"
With ActiveDocument.InlineShapes
.Item(intStart).Select
.Item(intStart).Delete
End With
Next intStart
'delete endnotes
WordApp.ActiveWindow.ActivePane.Activate
With WordApp.ActiveWindow.ActivePane.View
.SeekView = wdSeekEndnotes
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
'delete footers
WordApp.ActiveWindow.ActivePane.Activate
For intStart = 1 To 4 Step 1
Display_Message "Removing Footers in progress" &
String(intStart, "."), "w"
Select Case intStart
Case Is = 1
With
WordApp.ActiveWindow.ActivePane.View
.SeekView =
wdSeekCurrentPageFooter
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
Case Is = 2
With
WordApp.ActiveWindow.ActivePane.View
.SeekView = wdSeekPrimaryFooter
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
Case Is = 3
With
WordApp.ActiveWindow.ActivePane.View
.SeekView =
wdSeekEvenPagesFooter
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
Case Is = 4
With
WordApp.ActiveWindow.ActivePane.View
.SeekView =
wdSeekFirstPageFooter
If Err = 0 Then
Selection.WholeStory
Selection.Delete
End If
End With
End Select
Next intStart
'save as html
WordApp.ActiveDocument.Activate
WordApp.ActiveDocument.SaveAs FileName:=newDocName, _
fileformat:=wdFormatHTML,
_
EmbedTrueTypeFonts:=False, _
savenativepictureformat:=False
If Err <> 0 And Err <> 53 Then
Display_Message Err.Number & " " & Err.DESCRIPTION
& ", " & Err.Source, "e"
Options.DefaultFilePath(wdDocumentsPath) =
strPathTmp
Exit Sub
End If
'close origional document
WordApp.Documents(oldDocName).Activate
WordApp.ActiveWindow.ActivePane.Activate
WordApp.Documents.Close savechanges:=False
If Err <> 0 And Err <> 53 Then
Display_Message Err.Number & " " & Err.DESCRIPTION
& ", " & Err.Source, "e"
Options.DefaultFilePath(wdDocumentsPath) =
strPathTmp
Exit Sub
End If
Options.DefaultFilePath(wdDocumentsPath) = strPathTmp
If bolStarted = True Then
WordApp.Quit
End If
Set WordApp = Nothing
txtDoc.Text = newDocName
cmdConvert.Enabled = False
cmdConvert.Visible = False
Display_Message "Document Converted successfully", "w"
End Sub
