VB Forum / COM / July 2003

its owrking more or less. I can emove all images etc but when it
converts to html i still get a header file that has 4 required spaces in
it!  Arghh!!!!!!!!!1

teh code is as follows
----------------------------------------------------------

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 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(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
strContents = txtPath.Text & newDocName
Kill (strContents)

  'open and display document
  strContents = txtPath.Text & oldDocName
  Set wordDoc = Documents.Open(FileName:=strContents, _
                               ConfirmConversions:=False, _
                               ReadOnly:=False, _
                               AddToRecentFiles:=False, _
                               Revert:=False, _
                               Format:=wdDocument, _
                               Visible:=True)
' no idea why but i always 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

  ' make it active
  wordDoc.Activate
  WordApp.ActiveWindow.ActivePane.Activate
 
  'delete headers
  WordApp.ActiveWindow.ActivePane.Activate
 
  For intStart = 1 To 4 Step 1

           Select Case intStart
               
                  Case Is = 1
                       
                       With wordDoc.ActiveWindow.ActivePane.View
                           .SeekView = wdSeekCurrentPageHeader
                           If Err = 0 Then
                               Selection.WholeStory
                               Selection.Delete
                              Else
                                Err.Clear
                               End If
                       
                       End With
                 
                  Case Is = 2
                       
                       With wordDoc.ActiveWindow.ActivePane.View
                           .SeekView = wdSeekPrimaryHeader
                           If Err = 0 Then
                               Selection.WholeStory
                               Selection.Delete
                               Else
                                Err.Clear
                             End If
                               
                       End With
                       
                  Case Is = 3
                       
                       With wordDoc.ActiveWindow.ActivePane.View
                           .SeekView = wdSeekEvenPagesHeader
                           If Err = 0 Then
                               Selection.WholeStory
                               Selection.Delete
                               Else
                                Err.Clear
                              End If
                               
                       End With
                       
                  Case Is = 4
               
                       With wordDoc.ActiveWindow.ActivePane.View
                           .SeekView = wdSeekFirstPageHeader
                           If Err = 0 Then
                               Selection.WholeStory
                               Selection.Delete
                               Else
                                Err.Clear
                              End If
                               
                       End With
                       
               End Select
                   
       Next intStart
       
   ' remove external objects
   ' tried going forward but only caught teh first item so start at the
back
   wordDoc.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
   For intStart = ActiveDocument.InlineShapes.Count To 1 Step -1

          wordDoc.InlineShapes.Item(intStart).Delete
          If Err <> 0 Then
               Err.Clear
             End If
             
    Next intStart
 
  'delete endnotes
  wordDoc.ActiveWindow.ActivePane.Activate
 
  With wordDoc.ActiveWindow.ActivePane.View
     
      .SeekView = wdSeekEndnotes
     
      If Err = 0 Then
         Selection.WholeStory
         Selection.Delete
           Else
         Err.Clear
       End If
   
   End With
 
  'delete footers
  wordDoc.ActiveWindow.ActivePane.Activate
   
  For intStart = 1 To 4 Step 1
     
           Select Case intStart
           
                  Case Is = 1
     
                       With wordDoc.ActiveWindow.ActivePane.View
                           .SeekView = wdSeekCurrentPageFooter
                           If Err = 0 Then
                               Selection.WholeStory
                               Selection.Delete
                               Else
                                Err.Clear
                             End If
                               
                       End With
                       
                  Case Is = 2
     
                       With wordDoc.ActiveWindow.ActivePane.View
                           .SeekView = wdSeekPrimaryFooter
                           If Err = 0 Then
                               Selection.WholeStory
                               Selection.Delete
                               Else
                                Err.Clear
                              End If
                               
                       End With
                       
                  Case Is = 3
     
                       With wordDoc.ActiveWindow.ActivePane.View
                           .SeekView = wdSeekEvenPagesFooter
                           If Err = 0 Then
                               Selection.WholeStory
                               Selection.Delete
                               Else
                                Err.Clear
                              End If
                               
                       End With
                       
                  Case Is = 4
     
                       With wordDoc.ActiveWindow.ActivePane.View
                           .SeekView = wdSeekFirstPageFooter
                           If Err = 0 Then
                               Selection.WholeStory
                               Selection.Delete
                               Else
                                Err.Clear
                             End If
                               
                       End With
                       
               End Select
         
       Next intStart
 
  'save as html
   wordDoc.SaveAs FileName:=txtPath.Text & 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
       
txtDoc.Text = newDocName

cmdConvert.Enabled = False
cmdConvert.Visible = False

Display_Message "Document Converted successfully", "w"

Quit_Conversion:
If Err <> 0 Then
    Display_Message 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

Private Sub Display_Message(StrMessage as string, StrLevel as string)

msgbox strmessage & " " & strlevel

End sub

Woody
I am not responsible for anything you may see with my name attached to
it, i think.