Option Explicit

Dim strTableborder, strKeywords, strHTMLTitle, strThisfile, strShortfile, strHtmlfile, _
strThispath, strtempfile As String
Dim Headno As Integer
Dim FSys As Variant


Sub htmltag()
'
' Htmltag Macro: main procedure
' Macro created 1/11/02 by Jos Kingston. Last update 18/10/04
' www.joskingston.org   email jos@joskingston.org
'
' Jos Kingston asserts her moral rights of authorship of htmltag
' as laid down in the 1988 Copyright, Design and Patents Act.
' These rights include the right to be identified as the author of htmltag
' and the right not to have this work "subjected to derogatory treatment"
' - for example "addition, deletion or alteration prejudicial to the
' honour or reputation of the author."
'
' Table conversion only works on regular tables - merged or split cells will fail.
' No picture-handling capabilities - but links to pics will work.

' This macro has NOT been developed as a general purpose html converter.
' It is for customised use on Word files using a limited set of styles.
' There is an accompanying Word file htmltaguser.doc
' Which can be used for demonstration and further info about Htmltag.

' This macro copies the document to a temporary working file, then runs
' search and replace routines to insert html tags corresponding to
' the styles applied.
' When the routine is complete, the file is saved as unformatted text
' with an html extension. It is displayed in a browser window.
' The original document is then opened in Word for editing, following
' which the macro can be run again as required after final corrections.
' --------------------------------------------------------------------------

' Prepare for conversion - initialise variables, save to temp working file,
' Strip section and page breaks

    Getready
    
' Add a paragraph of normal text after headings to avoid tagging problems
    
    Consecheads

' Replace special html characters with html code


    Tagspecials

' Convert hyperlinks. Must be done before TOC generated
' At present won't convert Word internal document anchors - sortable

    Taghyperlinks

' Convert bold and italic to tags

    Tagbolditalic

' Tag Code, Red and Blue character styles

    Tagcharstyles
    
' Heading 3s are tagged with unique anchor names
' and linked to a contents list at the top of the file.
' NEED TO EDIT THIS ROUTINE IF YOU WANT TO USE A DIFFERENT LEVEL FOR HYPERLINKS.

    Tagcontents
  
' Internal links - convert Doclink character style to internal links.
' This only works to link to Heading 3, and if the Doclink text itself
' is exactly the same as the heading title.
' This is pretty tacky and bookmarks will be sorted sometime.

    Tagdoclinks
      
' Convert paras and heading styles to tags
' This must be done after character formatting and anchor tagging
' Otherwise nesting won't be correct

    TagParasandHeadings


' Tag bullets, numbered and indented lists.

    Taglists

'Once all tagging is done, whole document is reformatted in normal style.
'This prevents unwanted asterisks creeping into lists

    Setnormal
    

' Convert tables - only works properly where no split or merged cells

    Tagtables
   

' Add update and head info + end tags

    Tagheadinfo

    
' Save this file as a temporary text file

    Tempsave

' Clean out unwanted bits and pieces which creep in during replace routines etc.
 
    Cleantext
     
    
' Text file saved with html extension, process completed, user notified

    Finalhtml


End Sub

Sub Getready()
' Called from htmltag

 'Initialise filename and path variables
    
    strThispath = ActiveDocument.Path
    strThisfile = ActiveDocument.FullName
    strShortfile = Left(ActiveDocument.Name, Len(ActiveDocument.Name) - 4)
    strHtmlfile = strShortfile & ".html"

  ' Save document

    ActiveDocument.Save
    
' Save doc to temporary file for working with

    ChangeFileOpenDirectory strThispath
    ActiveDocument.SaveAs FileName:="Tempdoc.doc", FileFormat:=wdFormatDocument, _
        LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
        :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False
       
' Normal-style line added at end of file for process reasons

    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.Style = ActiveDocument.Styles("Normal")
    Selection.HomeKey Unit:=wdStory
       
' Strip all section breaks out of the file
' Full settings specified as this is first search in macro
' - don't need repeating every time.

    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^b"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
     
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    ' Strip all page breaks out of the file
    
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^m"
        .Replacement.Text = "^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    ' If the document has a TOC, delete it
    
    If ActiveDocument.TablesOfContents.Count > 0 Then
        ActiveDocument.TablesOfContents(1).Delete
    End If


End Sub

Sub Consecheads()

' this routine is to prevent tagging problems
' where two consecutive lines are set to a style
' a line of normal text between headings is required to avoid tagging problems
' the gobbledegook text is there to provide something which can be replaced with normal

Dim Headno As Integer
Dim Itemfound As Boolean
    Headno = 1
    Itemfound = True

    Do While Headno <= 5
        Selection.HomeKey Unit:=wdStory
            With Selection.Find
        .Text = ""
        .Replacement.Text = ""
    End With

        Do While Itemfound
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            Selection.Find.Style = ActiveDocument.Styles("Heading " & Headno)
   
            Selection.Find.Execute
            If Selection.Find.Found = False Then Itemfound = False
                 
            If Itemfound = True Then
                Selection.EndOf
                Selection.InsertParagraphAfter
                Selection.TypeText Text:="fiddledefooderops"
       
            End If
        Loop
        Itemfound = True
        Headno = Headno + 1
    
    Loop
    
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Normal")
    With Selection.Find
         .Text = "fiddledefooderops^p"
         .Replacement.Text = "^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
    End With

End Sub

Sub Tagspecials()
' Called from htmltag

' Must do & first, or other special characters get in a twist.

Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "&"
        .Replacement.Text = "&amp;"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    With Selection.Find
        .Text = "<"
        .Replacement.Text = "&lt;"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    With Selection.Find
        .Text = ">"
        .Replacement.Text = "&gt;"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
' Replace line breaks with br tag

    With Selection.Find
        .Text = "^l"
        .Replacement.Text = "<br />"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    

End Sub


Sub Taghyperlinks()
' Called from htmltag


Dim rngTemp As Range
Dim fieldLoop As Field
Dim fieldcontent As String
Dim Fieldno As Integer
Fieldno = 1

    Selection.HomeKey Unit:=wdStory
    For Each fieldLoop In ActiveDocument.Fields
    
        If fieldLoop.Type = wdFieldHyperlink Then
            
            If ActiveDocument.Fields.Count >= Fieldno Then
                fieldcontent = "<a href=" + fieldLoop.Code.Text + ">"
                
                Set rngTemp = ActiveDocument.Fields(Fieldno).Result
                
                If ActiveDocument.Fields.Count > Fieldno Then
                    Fieldno = Fieldno + 1
                End If
                
 ' If not condition prevents incorrect tagging of Word bookmark hyperlinks
 
                If Not InStr(LCase(fieldLoop.Code.Text), "\l") <> 0 Then
                rngTemp.Text = fieldcontent + fieldLoop.Result.Text + "</a>"
                ActiveDocument.Fields(Fieldno).Update
                End If
            
            End If
        
        End If
    
    Next fieldLoop

' Get rid of the word HYPERLINK which is included in Word field content
' Two search routines to handle space or no space before

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "<a href=HYPERLINK"
        .Replacement.Text = "<a href="
    
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    With Selection.Find
        .Text = "<a href= HYPERLINK"
        .Replacement.Text = "<a href="
    
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    
End Sub

Sub Tagbolditalic()
' Called from htmltag

' First, get shot of bold and italic in headings so they don't override .css

       Headno = 1
       
       Do While Headno <= 5
       
            With ActiveDocument.Styles("Heading " & Headno).Font
                .Bold = False
                .Italic = False
            End With
            Headno = Headno + 1
            
        Loop


' Now, convert any bold or italic paragraph ends to not bold, not italic
' Else they'll get improperly nested between style tags.
' Note: S&R routines based on recording macros won't work for this
' They don't record replacement formatting!!

    With ActiveDocument.Content.Find
        .ClearFormatting
        .Font.Bold = True
        With .Replacement
            .ClearFormatting
            .Font.Bold = False
        End With
        .Execute FindText:="^p", ReplaceWith:="^p", _
            Format:=True, Replace:=wdReplaceAll
    End With
    
    With ActiveDocument.Content.Find
        .ClearFormatting
        .Font.Italic = True
        With .Replacement
            .ClearFormatting
            .Font.Italic = False
        End With
        .Execute FindText:="^p", ReplaceWith:="^p", _
            Format:=True, Replace:=wdReplaceAll
    End With

' Now add the bold and italic tags
' Note - if you do this the other way round they will be incorrectly nested!!
    
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    With Selection.Find
        .Font.Italic = True
        .Text = ""
        .Replacement.Text = "<i>^&</i>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
       With Selection.Find
        .Font.Bold = True
        .Text = ""
        .Replacement.Text = "<b>^&</b>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Sub

Sub Tagcharstyles()
' Called from htmltag


' To prevent incorrectly nested tags, paragraph ends must have style cleared first
   
' Code character style

    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Code")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Default Paragraph Font")
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    With Selection.Find
        .Text = ""
        .Replacement.Text = "<tt>^&</tt>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
' Red character style

    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Red")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Default Paragraph Font")
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
  
    With Selection.Find
            .Text = ""
            .Replacement.Text = "<font color=""#FF0000"">^&</font>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

' Blue character style
    
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Blue")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Default Paragraph Font")
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    With Selection.Find
            .Text = ""
            .Replacement.Text = "<font color=""#0000FF"">^&</font>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    
End Sub

Sub Tagcontents()
' Called from htmltag

' This is tidied up into final html code with two search and replace routines.
' I did it this way because I just couldn't get it to create active links if
' the whole thing was in the InsertAfter line.
' Note the complexities when including inverted commas in tags.
' To differentiate from VBA reserved use of ", must use ""

Dim Itemno As Integer
Itemno = 1

Selection.HomeKey Unit:=wdStory

    With ActiveDocument.Content.Find
        .ClearFormatting
        .Style = wdStyleHeading3
        
        Do While .Execute(FindText:="", Forward:=True, _
                Format:=True) = True
            
            With .Parent
                .StartOf Unit:=wdParagraph, Extend:=wdMove
                .InsertAfter "<aname=Item" + CStr(Itemno) + "></a>"
                .Move Unit:=wdParagraph, Count:=1
            End With
            
            Itemno = Itemno + 1
        Loop
        
    End With

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find
        .Text = "<aname=Item"
        .Replacement.Text = "<a name = ""Item"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    With Selection.Find
        .Text = "></a>"
        .Replacement.Text = """></a>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    
' Now to create the contents list and tag it correctly
' You'll need to modify if you don't want to use Heading 3 level - simple
' Just change every instance of 3 to 2

    Selection.HomeKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.Style = ActiveDocument.Styles("Normal")
    
    Selection.HomeKey Unit:=wdStory
    
        With ActiveDocument.Content.Find
        .ClearFormatting
        .Style = wdStyleHeading3
        
            If .Execute(FindText:="", Forward:=True, _
                    Format:=True) = True Then
                    
                With ActiveDocument
                     Selection.TypeText Text:="<p>"
                     Selection.TypeParagraph
                    .TablesOfContents.Add Range:=Selection.Range, UseHeadingStyles:=True, _
                    UpperHeadingLevel:=3, LowerHeadingLevel:=3, IncludePageNumbers:=False
                    Selection.TypeText Text:="</p>"
                End With
                
            End If
        
        End With
  
'Note that find style set to Toc 3 for following set of s&rs
' Change if you're using a different heading level

        Selection.HomeKey Unit:=wdStory
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        Selection.Find.Style = ActiveDocument.Styles("Toc 3")
    
        With Selection.Find
            .Text = "<a name = ""Item"
            .Replacement.Text = "<a href=""#Item"
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    
        With Selection.Find
            .Text = "</a>"
            .Replacement.Text = ""
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    
        With Selection.Find
        .Text = "^p"
        .Replacement.Text = "</a><br />^l"
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
        
End Sub

Sub Tagdoclinks()
' Called from htmltag

' The tagged reference to the specified heading link is located in the
' contents list which has been generated at the top of the document,
' then the Doclink text is replaced with this tagged reference.
' As each Doclink is dealt with, it's reset as Code character style.
' This is done so that it's ignored when the loop routine is repeated.

' First, strip style from para ends (as with other character styles)

   Selection.HomeKey Unit:=wdStory
   Selection.Find.ClearFormatting
   Selection.Find.Style = ActiveDocument.Styles("Doclink")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Default Paragraph Font")
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   ' End of that bit
    
    Dim Linkto As String
    Dim Taggedlink As String
    Dim Doclinkfound As Boolean
    Doclinkfound = True
    
    Do While Doclinkfound
         Taggedlink = ""
         Linkto = ""
         Selection.HomeKey Unit:=wdStory
         Selection.Find.ClearFormatting
         Selection.Find.Style = ActiveDocument.Styles("Doclink")
         Selection.Find.Text = ""
         Selection.Find.Execute
         
         If Selection.Find.Found = False Then Doclinkfound = False
         
         If Doclinkfound = True Then
             Linkto = Selection.Text
             Selection.HomeKey Unit:=wdStory
             Selection.Find.ClearFormatting
             Selection.Find.Text = Linkto
             Selection.Find.Execute
             Selection.HomeKey Unit:=wdLine
             Selection.EndKey Unit:=wdLine, Extend:=wdExtend
                                        
        'The above process finds a match for linkto in tof hyperlinks
        'Line below strips out <br /> tag from selection to recycle taggedlink
        'But this routine halts macro if doclink is to last of tof hyperlinks
        'with a parameter too long message
        
             Selection.MoveLeft Unit:=wdCharacter, Count:=7, Extend:=wdExtend
             Taggedlink = Selection.Text
             Selection.HomeKey Unit:=wdStory
             Selection.Find.Style = ActiveDocument.Styles("Doclink")
             Selection.Find.Replacement.Style = ActiveDocument.Styles("Code")
             
             With Selection.Find
                 .Text = Linkto
                 .Replacement.Text = Taggedlink
             End With
             Selection.Find.Execute Replace:=wdReplaceOne
         
         End If
     
     Loop
     
End Sub

Sub TagParasandHeadings()
' Called from htmltag

    Dim Tableno As Integer
      
    Headno = 1
    Tableno = 1
    
' Tag all paragraphs with <p> and </p>.^& returns the Find What text.
' Note that para tags have to be stripped out later from styles where not reqd.

    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
   
       With Selection.Find
         .Text = "^p"
          .Replacement.Text = "</p>^p<p>"
       End With
       Selection.Find.Execute Replace:=wdReplaceAll
    
   
' Headings won't tag correctly if they're immediately followed by a table
' Code here fixes this
    
    Do While Tableno <= ActiveDocument.Tables.Count
   
        ActiveDocument.Tables(Tableno).Select
        Selection.splittable
        ' Selection.MoveUp Unit:=wdLine, Count:=1
        ' Selection.InsertParagraphAfter

        
        Tableno = Tableno + 1
    
    Loop
   
'Heading tagging done as two routines so Word para end doesn't precede closing tag
'Then corrects places where tagging has put <p> into heading styles

    Do While Headno <= 5
      
        Selection.HomeKey Unit:=wdStory
        Selection.Find.ClearFormatting
        Selection.Find.Style = ActiveDocument.Styles("Heading " & Headno)
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = ""
            .Replacement.Text = "<h" & Headno & ">^&"
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    
        With Selection.Find
            .Text = "^p"
            .Replacement.Text = "</h" & Headno & ">^p"
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
      
    
        With Selection.Find
            .Text = "<p>"
            .Replacement.Text = ""
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
        
        With Selection.Find
            .Text = "</p>"
            .Replacement.Text = ""
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
    
        Headno = Headno + 1
 
    Loop
        
    
End Sub

Sub Taglists()
' Called from htmltag

' Style s&r routine puts tags at beginning and end of list.
' Each list item then has to be handled separately.
' Style then changed to normal to avoid unwanted asterisks in html
' The above routines put a redundant line at the end of each list.
' This is stripped out.
' Note that line spacing for indents is included as style in head info

' Plain indent - must be done before numlist 2 gets blockquote tag added

    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("indent")
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = "<blockquote>^&</blockquote>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       
   Selection.Find.ClearFormatting
   With Selection.Find
       .Text = "^p</blockquote>"
        .Replacement.Text = "</blockquote>^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
 
' Tag bullets

    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("bullet")
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = "<ul><li>^&</li></ul>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

   
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "</li>^p<li>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       
    With Selection.Find
        .Text = "<p>"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       
    With Selection.Find
        .Text = "</p>"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
     With Selection.Find
        .Text = "</ul></li>^p<li>"
        .Replacement.Text = "</ul>^p"
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
    
    
   With Selection.Find
        .Text = "^p<li></li></ul>"
        .Replacement.Text = "</ul>^p"
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
    

' Numbered list level 1 indent
    
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Numlist")
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = "<ol><li>^&</li></ol>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
     
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "</li>^p<li>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       
    With Selection.Find
        .Text = "<p>"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       
    With Selection.Find
        .Text = "</p>"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "</ol></li>^p<li>"
        .Replacement.Text = "</ol>^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    With Selection.Find
        .Text = "^p<li></li></ol>"
        .Replacement.Text = "</ol>^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
   
' Numbered list level 2 indent
   
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Numlist2")
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = "<blockquote><ol><li>^&</ol></blockquote>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
     
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "</li>^p<li>"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       
    With Selection.Find
        .Text = "<p>"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       
    With Selection.Find
        .Text = "</p>"
        .Replacement.Text = ""
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "^p<li></ol></blockquote>"
        .Replacement.Text = "</ol></blockquote>^p"
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Sub

Sub Setnormal()
' Called from htmltag

'Note that Word style formatting is contained in paragraph markers
'Normal line pushed in first at end - s&r routine won't convert last para in doc?!

    
   Selection.EndKey Unit:=wdStory
   Selection.TypeParagraph
   Selection.Style = ActiveDocument.Styles("Normal")
  
   Selection.HomeKey Unit:=wdStory
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.Style = ActiveDocument.Styles("Normal")
   With Selection.Find
       .Text = "^p"
       .Replacement.Text = "^p"
   End With
   Selection.Find.Execute Replace:=wdReplaceAll

End Sub

Sub Tagtables()
' Called from htmltag

' If there are tables, ask user what border they want for them and then convert
' Split table bit is to add a blank line in front of table before processing.
' This is a fix because otherwise closing heading tag before table
' disappears for reasons unfathomed.
' Then add opening table, row, cell tags.
' Note that once the table has been converted to text, it's no longer a table.
' So, the next table to process will always be the first table.
   
    Selection.HomeKey Unit:=wdStory
    Dim Moretablesfound As Boolean
    Moretablesfound = True
        
        If ActiveDocument.Tables.Count > 0 Then
             strTableborder = InputBox("Table border? 0 for none up to 3 (3 pixels wide)")
        End If
       
       Do While Moretablesfound
  
        If ActiveDocument.Tables.Count = 0 Then
              Moretablesfound = False
        End If
            
        If Moretablesfound = True Then
        
' Add a paragraph after the table to prevent tagging errors

            ActiveDocument.Tables(1).Select
            Selection.EndKey
            Selection.MoveDown Unit:=wdParagraph, Count:=2
            Selection.TypeParagraph
            Selection.TypeText Text:="<p>"
            
' Add table opening tags
   
            Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst
            Selection.TypeText Text:="<table border=""" + strTableborder _
            + """ width=""95%""><tr><td>"
        
' Before table is converted to text,
' <p> and </p>tags which got into it from previous formatting routines are stripped out.
' Then, paragraph endings within cells are handled.

            ActiveDocument.Tables(1).Select
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            
            With Selection.Find
                .Text = "<p>"
                .Replacement.Text = ""
                .Forward = True
                .Wrap = wdFindStop
            End With
            
            Selection.Find.Execute Replace:=wdReplaceAll
                
            ActiveDocument.Tables(1).Select
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "</p>"
                .Replacement.Text = ""
                .Wrap = wdFindStop
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
                     
            ActiveDocument.Tables(1).Select
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "^p"
                .Replacement.Text = "<br />^l"
                .Wrap = wdFindStop
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
            
 ' Put a </p> back in front of <table. To prevent errors which otherwise
 ' can arise when no blank line between table and preceding text.

            ActiveDocument.Tables(1).Select
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "<table"
                .Replacement.Text = "</p><table"
                .Wrap = wdFindStop
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
            
' Fixes 1st cell having line end at top
           ActiveDocument.Tables(1).Select
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "<tr><td><br />"
                .Replacement.Text = "^l<tr><td>"
                .Wrap = wdFindStop
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
            
                 
            Selection.Rows.ConvertToText Separator:=wdSeparateByTabs
              
' Nested tables left out as presumably don't work in pre-2002 Word
' , NestedTables:= True
            

' get rid of any blank lines generated when table converted to text
           
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "^p^p"
                .Replacement.Text = "^p"
                .Wrap = wdFindStop
           
            End With
            Selection.Find.Execute Replace:=wdReplaceAll
            
' replace line endings with cell and row end/start tags
            With Selection.Find
                .Text = "^p"
                .Replacement.Text = "</td></tr>^p<tr><td>"
                .Wrap = wdFindStop
                 End With
            Selection.Find.Execute Replace:=wdReplaceAll

' replace tabs with cell end/start tags
            With Selection.Find
                .Text = "^t"
                .Replacement.Text = "</td>^p<td>"
                .Wrap = wdFindStop
            End With
            Selection.Find.Execute Replace:=wdReplaceAll

' put nonbreaking space in empty cells
            With Selection.Find
                .Text = "<td></td>"
                .Replacement.Text = "<td>&nbsp;</td>"
                .Wrap = wdFindStop
            End With
            Selection.Find.Execute Replace:=wdReplaceAll

' add table closing tabs at end of table
          Selection.EndKey
          Selection.TypeParagraph
          Selection.TypeText Text:="</td></tr></table>"
          Selection.TypeParagraph
           
         End If
     Loop

    
' remove redundant row added by above routines at bottom of table
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "<tr></tr>"
                .Replacement.Text = "</tr>^p"
                .Forward = True
                .Wrap = wdFindContinue
              End With
            Selection.Find.Execute Replace:=wdReplaceAll

' second bit of same routine
            Selection.Find.ClearFormatting
            Selection.Find.Replacement.ClearFormatting
            With Selection.Find
                .Text = "<tr><td></p>"
                .Replacement.Text = "<tr><td>"
                .Forward = True
                .Wrap = wdFindContinue
              End With
            Selection.Find.Execute Replace:=wdReplaceAll


End Sub

Sub Tagheadinfo()
' Called from htmltag

' Add update info at top of file
    
    Selection.HomeKey Unit:=wdStory
    Selection.TypeParagraph
    Selection.Style = ActiveDocument.Styles("Normal")
    Selection.TypeText Text:="<p><i>File updated </i>"
    Selection.InsertDateTime DateTimeFormat:="dd/MM/yy HH:mm", InsertAsField:= _
         False, InsertAsFullWidth:=False
    Selection.TypeText Text:="</p>"
    
    ' doesn 't work from Insert date in 97 DateLanguage:=wdEnglishUK,
    ' CalendarType:=wdCalendarWestern,
    


   

    
' Add html header and end tags at top and bottom of file
' Note 2 sets of quote marks needed by VBA to distinguish quotes in html tags
' from quotes required by VBA
    
    Selection.HomeKey Unit:=wdStory
    Selection.TypeText Text:= _
       "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Transitional//EN"""
    Selection.TypeParagraph
    Selection.TypeText Text:= _
        """http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"">"
    Selection.TypeParagraph
    Selection.TypeText Text:="<html>"
    Selection.TypeParagraph
    Selection.TypeText Text:="<head>"
    Selection.TypeParagraph
    Selection.TypeText Text:= _
        "<meta http-equiv=""Content-Type"" content=""text/html; "
    Selection.TypeText Text:="charset=iso-8859-1"" />"
    
' Ask user for html title and Keywords; store

    Selection.TypeParagraph
    strHTMLTitle = InputBox("Title to appear at top of browser window?")
    Selection.TypeText Text:="<title>" + strHTMLTitle + "</title>"
    Selection.TypeParagraph
        strKeywords = InputBox("Keywords for this page - put a comma between them")
    Selection.TypeText Text:="<meta name=""Keywords"" content="""
    Selection.TypeText Text:=strKeywords + """ />"
    Selection.TypeParagraph
      
' This line calls the cascading style sheet for Macbeth pages
' CHANGE OR REM OUT FOR DIFFERENT OR NO CSS
    
    Selection.TypeText Text:= _
        "<link rel=""stylesheet"" type=""text/css"" href=""htmltag.css"" />"
    Selection.TypeParagraph
    
    

    
' Add closing head, body and closing html tags
   
    Selection.TypeText Text:="</head>"
    Selection.TypeParagraph
    Selection.TypeText Text:="<body>"
        

    Selection.EndKey Unit:=wdStory
    Selection.TypeParagraph
     
    Selection.TypeText Text:="</body>"
    Selection.TypeParagraph
    Selection.TypeText Text:="</html>"
    
End Sub

Sub Tempsave()
' Called from htmltag

' May be a good idea to add Unicode switch

 strThispath = ActiveDocument.Path
  ChangeFileOpenDirectory strThispath
  ActiveDocument.SaveAs FileName:="Temptext.txt", FileFormat:= _
        wdFormatText, LockComments:=False, Password:="", AddToRecentFiles:=False, _
        WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
         SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False
  
' Now save again as Tempdoc (so the macro can keep running!)

       ActiveDocument.SaveAs FileName:="Tempdoc.doc", FileFormat:=wdFormatDocument, _
        LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
        :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
        SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False
     
' Reopen text file for final cleanup. (Cleantext procedure)

  ChangeFileOpenDirectory strThispath
    Documents.Open FileName:="Temptext.txt", ConfirmConversions:=False, _
        ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto
        
        ' taken out because doesn't work in 97: Encoding:=1252
        
End Sub

Sub Cleantext()
' Called from htmltag

 ' This gets shot of extra bits which appear in text file
 ' e.g. if it contains page nos, footers
 
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "</html>"
    End With
    Selection.Find.Execute
    Selection.EndKey Unit:=wdStory, Extend:=wdExtend
    Selection.Cut
    Selection.TypeText Text:="</html>"
    
' Cleanup redundant tags from global s&r routines
    
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "<p></p>"
            .Replacement.Text = ""
            .Wrap = wdFindContinue
        End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "<p>^p"
            .Replacement.Text = "^p"
            .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
     Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "<body></p>"
            .Replacement.Text = "<body>"
            .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "<p><p>"
            .Replacement.Text = "<p>"
            .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "</p></p>"
            .Replacement.Text = "</p>"
            .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
' Fix bad tagging with headings and paragraph ends (Scream!)

Headno = 1
       
       Do While Headno <= 5
       
 ' This is to handle blank lines formatted to a style
 ' but doesn't work?
 
            Selection.HomeKey Unit:=wdStory
             With Selection.Find
                     .Text = "<h" & Headno & ">" & "</h" & Headno & ">"
                     .Replacement.Text = "<h" & Headno & ">"
                     .Wrap = wdFindContinue
             End With
             Selection.Find.Execute Replace:=wdReplaceAll
             
             Selection.HomeKey Unit:=wdStory
             With Selection.Find
                     .Text = "^p</h" & Headno & ">"
                     .Replacement.Text = ""
                     .Wrap = wdFindContinue
             End With
             Selection.Find.Execute Replace:=wdReplaceAll
                       
' special treatment needed for blank lines at heading level
' which gets formatted as hyperlinks

             Selection.HomeKey Unit:=wdStory
             With Selection.Find
                     .Text = "</h" & Headno & ">^p" & "<a name"
                     .Replacement.Text = "<a name"
                     .Wrap = wdFindContinue
             End With
             Selection.Find.Execute Replace:=wdReplaceAll
             
' this bit is for what happens if headings immediately precede tables

             Selection.HomeKey Unit:=wdStory
             With Selection.Find
                     .Text = "</h" & Headno & ">^p^p" & "</p>"
                     .Replacement.Text = "</h" & Headno & ">^p"
                     .Wrap = wdFindContinue
             End With
             Selection.Find.Execute Replace:=wdReplaceAll

 ' this bit is for what happens if headings immediately follow tables

             Selection.HomeKey Unit:=wdStory
             With Selection.Find
                     .Text = "<p><h" & Headno & ">"
                     .Replacement.Text = "<h" & Headno & ">"
                     .Wrap = wdFindContinue
             End With
             Selection.Find.Execute Replace:=wdReplaceAll
             
             Headno = Headno + 1
            
        Loop
' This bit is a fix because Word capitalises tags round bold/italic words
' which are all capitals!
    
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "<B>"
            .Replacement.Text = "<b>"
            .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "</B>"
            .Replacement.Text = "</b>"
            .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "<I>"
            .Replacement.Text = "<i>"
            .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    With Selection.Find
            .Text = "</I>"
            .Replacement.Text = "</i>"
            .Wrap = wdFindContinue
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
       
End Sub

Sub Finalhtml()
' Called from htmltag

    ActiveDocument.SaveAs FileName:=strHtmlfile, FileFormat:= _
        wdFormatText, LockComments:=False, Password:="", AddToRecentFiles:=False, _
        WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
         SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
        False
  
   
  ' Original Word file now opened again for user to compare and correct

  ChangeFileOpenDirectory strThispath
    Documents.Open FileName:=strThisfile, ConfirmConversions:=True, ReadOnly _
        :=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
        :="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
        , Format:=wdOpenFormatAuto

Windows(strHtmlfile).Close

' Process complete - message to user
' Html file displayed in browser window when user OKs

    Dim Msg, Style, Title, Response
  
    Msg = "Html has been saved as " + strHtmlfile + Chr(13) + Chr(13) _
        + "The converted file will now appear in a browser window." + Chr(13) + Chr(13) _
        + "If there are errors, click back into your original Word file from the Taskbar." _
        + Chr(13) + "Correct your formatting in Word then run the macro again."
    Style = vbOKOnly
    Title = "Conversion to HTML is complete"
    Response = MsgBox(Msg, Style, Title)
    If Response = vbOK Then
      ActiveDocument.FollowHyperlink Address:="file:" + strHtmlfile
    End If
    
' Tempdoc can now be closed

 Windows("Tempdoc.doc").Close

' Temporary files deleted
    Set FSys = CreateObject("Scripting.FileSystemObject")
    FSys.DeleteFile "Tempdoc.doc"
    FSys.DeleteFile "temptext.txt"
    
' Find and replace window cleared
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
    End With

End Sub

Sub bullets()
' In development - to save manual tagging with htmltag bullet style

Dim oList As List
Dim oPara As Paragraph
Dim iResponse

For Each oList In ActiveDocument.Lists
    For Each oPara In oList.ListParagraphs
        
            oPara.Range.Select
            iResponse = MsgBox("Set to bullet style?", _
vbYesNo)
            If iResponse = vbYes Then
                oPara.Range.Style = ActiveDocument.Styles("Bullet")

            End If
        
    Next oPara
Next oList

End Sub

Sub Altminutes()
' Pre-htmltag conversion macro to handle ALT minutes
    
    strThispath = ActiveDocument.Path
    strThisfile = ActiveDocument.Name
    strtempfile = "htmltag" & strThisfile
 
  ' Save document

    ActiveDocument.Save
    
' Save doc to temporary file for working with
' Save to Word 2 format converts outline numbers in styles to hard numbers
' File has to be closed and opened again for this to take effect
' Then saved back again to standard Word to avoid macro hiccups
' Original file re-opened before temp file closed
' So that macro can continue running

    ChangeFileOpenDirectory strThispath
    ActiveDocument.SaveAs FileName:=strtempfile, _
        FileFormat:=106, LockComments:=False, Password:="", AddToRecentFiles:= _
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    
    Documents.Open FileName:=strThisfile
    Windows(strtempfile).Activate
    ActiveDocument.Close
    Documents.Open FileName:=strtempfile
    ActiveDocument.SaveAs FileName:=strtempfile, _
        FileFormat:=wdFormatDocument, LockComments:=False, Password:="", _
        AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
        EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
        :=False, SaveAsAOCELetter:=False


  
    With ActiveDocument
        .UpdateStylesOnOpen = True
        .AttachedTemplate = _
            "C:\WINDOWS\Application Data\Microsoft\Templates\htmltag.dot"
    End With
    
 
' downgradeheads done twice so heading 1 level becomes heading 3 etc
    downgradeheads
    downgradeheads
    
    delhardbulls
    
' set top line of file to Heading 1 style

    Selection.HomeKey Unit:=wdStory
    Selection.Style = ActiveDocument.Styles("Heading 1")
    
    nowrunhtmltag

   
    
End Sub

Sub downgradeheads()
' Called from Altminutes
' Should really be put in a loop and use variables for headings

    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 5")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Heading 6")
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 4")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Heading 5")
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 3")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Heading 4")
    Selection.Find.Execute Replace:=wdReplaceAll
   
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 2")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Heading 3")
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles("Heading 1")
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles("Heading 2")
    Selection.Find.Execute Replace:=wdReplaceAll

End Sub
Sub delhardbulls()
' Called from Altminutes


Dim Itemfound As Boolean
    Itemfound = True
    
    Selection.Find.ClearFormatting
    Do While Itemfound
    Selection.Find.Style = ActiveDocument.Styles("Bullet")
      With Selection.Find
        .Text = "^?^t"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
      
         If Selection.Find.Found = False Then Itemfound = False
         
         If Itemfound = True Then
    Selection.Cut
    End If
    
    Loop
    
' Numlist: first looks for 2 digits before tab to allow numbers up to 99
' n.b. wd 2 conversion puts in fullstop which needs stripping out

    Itemfound = True
    Selection.Find.ClearFormatting
    Do While Itemfound
    Selection.Find.Style = ActiveDocument.Styles("Numlist")
      With Selection.Find
        .Text = "^#^#.^t"
        .Replacement.Text = ""
      End With
    Selection.Find.Execute
      
         If Selection.Find.Found = False Then Itemfound = False
         
         If Itemfound = True Then
            Selection.Cut
        End If
    
    Loop
    
    Itemfound = True
    Selection.Find.ClearFormatting
    Do While Itemfound
    Selection.Find.Style = ActiveDocument.Styles("Numlist")
      With Selection.Find
        .Text = "^#.^t"
        .Replacement.Text = ""
      End With
    Selection.Find.Execute
      
         If Selection.Find.Found = False Then Itemfound = False
         
         If Itemfound = True Then
            Selection.Cut
        End If
    
    Loop
    
' Same routines now run for Numlist2

    Itemfound = True
    Selection.Find.ClearFormatting
    Do While Itemfound
    Selection.Find.Style = ActiveDocument.Styles("Numlist2")
      With Selection.Find
        .Text = "^#^#.^t"
        .Replacement.Text = ""
      End With
    Selection.Find.Execute
      
         If Selection.Find.Found = False Then Itemfound = False
         
         If Itemfound = True Then
            Selection.Cut
        End If
    
    Loop
        Itemfound = True
    Selection.Find.ClearFormatting
    Do While Itemfound
    Selection.Find.Style = ActiveDocument.Styles("Numlist2")
      With Selection.Find
        .Text = "^#.^t"
        .Replacement.Text = ""
      End With
    Selection.Find.Execute
      
         If Selection.Find.Found = False Then Itemfound = False
         
         If Itemfound = True Then
            Selection.Cut
        End If
    
    Loop
   
End Sub


Sub nowrunhtmltag()
' Called from Altminutes

Dim Msg, Style, Title, Response
  
    Msg = "ALT minutes pre-conversion routines now complete." _
            + " Make sure the active file is " & strtempfile _
            + " and click the htmltag button."
    Style = vbOKOnly
    Title = "Intermediate conversion for ALT minutes complete"
    Response = MsgBox(Msg, Style, Title)
   
End Sub