Public Sub GetHTMLStyles() Dim objParagraph As Word.Paragraph Dim objStyle As Word.Style, blnHTMLStyleFound As Boolean

'Check for Word document with Word HTML Styles.
With Application
    If .Documents.Count = 0 Then
        Call VBA.MsgBox("There are no documents open to format.")
        Exit Sub
    Else
        For Each objStyle In Application.ActiveDocument.Styles
            If objStyle.InUse And objStyle.NameLocal = "HTML Markup" Then
                blnHTMLStyleFound = True
                Exit For
            End If
        Next
        
        If Not (blnHTMLStyleFound) Then
            Call VBA.MsgBox("Word HTML Styles are not in use in this document." _
               & VBA.Space(1) & "Formatting cannot continue.")
            Exit Sub
        End If
        
    End If
End With

'Select all.
Call Application.ActiveDocument.Range.Select

'Format all text.
Call HTMLFormatAll


'Format all headings.
Call HTMLFormatHeading

'Format body (avoid Word tables).
For Each objParagraph In Application.ActiveDocument.Paragraphs
    If Not (objParagraph.Style Like "H?") And (Application.Selection.Cells.Count = 0) Then
        Call objParagraph.Range.Select
        Call HTMLFormatBody
    End If
Next

Application.ActiveWindow.ActivePane.View.ShowAll = True
Application.Selection.HomeKey Unit:=wdStory
Call FindReset
Call VBA.MsgBox("Formatting complete.")

End Sub

Private Sub HTMLFormatAll() 'Replace “ with “. Call FindReset With Selection.Find .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False

    .Text = "“"
    .Replacement.Text = "“"
    .Replacement.Style = ActiveDocument.Styles("HTML Markup")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

'Replace ” with ”.
Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Text = "”"
    .Replacement.Text = "”"
    .Replacement.Style = ActiveDocument.Styles("HTML Markup")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

'Replace ‘ with ‘.
Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Text = "‘"
    .Replacement.Text = "‘"
    .Replacement.Style = ActiveDocument.Styles("HTML Markup")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

'Replace ’ with ’.
Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Text = "’"
    .Replacement.Text = "’"
    .Replacement.Style = ActiveDocument.Styles("HTML Markup")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

'Replace - with —.
Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Text = "-"
    .Replacement.Text = "—"
    .Replacement.Style = ActiveDocument.Styles("HTML Markup")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

'Replace - with –.
Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Text = "-"
    .Replacement.Text = "–"
    .Replacement.Style = ActiveDocument.Styles("HTML Markup")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

'Replace … with ….
Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Text = "…"
    .Replacement.Text = "…"
    .Replacement.Style = ActiveDocument.Styles("HTML Markup")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

End Sub

Private Sub HTMLFormatHeading() 'Replace Word .DOC Headings with Word HTML Headings. Call FindReset With Selection.Find .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False

    .Style = ActiveDocument.Styles("Heading 1")
    .Replacement.Style = ActiveDocument.Styles("H1")
    Call .Execute(Replace:=wdReplaceAll)

End With

Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Style = ActiveDocument.Styles("Heading 2")
    .Replacement.Style = ActiveDocument.Styles("H2")
    Call .Execute(Replace:=wdReplaceAll)

End With

Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Style = ActiveDocument.Styles("Heading 3")
    .Replacement.Style = ActiveDocument.Styles("H3")
    Call .Execute(Replace:=wdReplaceAll)

End With

Call FindReset

End Sub

Private Sub HTMLFormatBody() 'Replace Bold formatting with Strong style. Call FindReset With Selection.Find .Forward = True .Wrap = wdFindStop .Format = True .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False

    .Font.Bold = True
    .Replacement.Style = ActiveDocument.Styles("Strong")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

'Replace Italic formatting with Emphasis style.
Call FindReset
With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    
    .Font.Italic = True
    .Replacement.Style = ActiveDocument.Styles("Emphasis")
    
    Call .Execute(Replace:=wdReplaceAll)
End With

End Sub

Private Sub FindReset() With Selection.Find Call .ClearFormatting Call .Replacement.ClearFormatting .Text = vbNullString .Replacement.Text = vbNullString End With End Sub