Attribute VB_Name = "Doc2Html2Doc"
' ===============================
' Doc2Html2Doc
'
' You are free to do whatever you want with this code except sell it.
' No warranties, etc. etc.
'
' Copyright (C) 2004 Ryan Ginstrom
'
' OVERVIEW
'
' What it handles:
'   font face
'   font colors
'   bold
'   italic
'   underline
'   superscript and subscript
'   most special (e.g. Greek) symbols
'
' What it doesn't handle:
'   font size
'   background color (highlight)
'   font colors other than the basic Word 97 text colors
'   hyperlinks
'   styles/headings (H1, H2...)
'   paragraph formatting
'   ... and basically anything not mentioned in "What it handles:"
'
' INCLUDED FUNCTIONS/SUBS
' TestGetSelectionAsHtml
' TestHtml2Doc
'       - test routines
' WriteSelectionAsDoc
' WriteSelectionAsHtml
'       - convert html to and from doc formatting within document
' GetSelectionAsHtml() as String
' Html2Doc( HtmlText as String )
'       - functions/subs for same
' ... And various other helper routines. Concat and ReplaceText may be of interest
' as VBA solutions to general programming problems (both routines lifted from elsewhere)
'
' ===============================


Option Explicit

Private CurrentBoldState As Boolean
Private CurrentItalicState As Boolean
Private CurrentUnderlineState As Long
Private CurrentFontName As String
Private CurrentForeColor As Long
Private CurrentSupState As Long

Private Const SUP_NONE As Long = 0
Private Const SUP_SUPER As Long = 1
Private Const SUP_SUB As Long = 2

' for concat
Private ccOffset As Long
Private Const ccIncrement = 256

' Test routines
Sub TestGetSelectionAsHtml()

    MsgBox GetSelectionAsHtml

End Sub

Sub TestHtml2Doc()

    Html2Doc "<font face=""Tahoma""><b>HELLO</b>, </font><font face=""Courier""><font color=""red""><b>world</b></font></font>"

End Sub

Sub WriteSelectionAsDoc()

    Dim html As String
    
    html = Selection.Text
    
    Selection.Collapse wdCollapseEnd
    Selection.TypeText vbCrLf
    
    Dim CurrentStart As Long
    CurrentStart = Selection.Start
    
    Html2Doc html

    Selection.Start = CurrentStart

End Sub

Sub WriteSelectionAsHTml()

    Dim html As String
    
    html = GetSelectionAsHtml
    
    Selection.Collapse wdCollapseEnd
    Selection.TypeText vbCrLf
    
    Dim CurrentStart As Long
    CurrentStart = Selection.Start
    
    Selection.TypeText html
    
    Selection.Start = CurrentStart

End Sub


' ========================
' | GetSelectionAsHtml
' ========================
Function GetSelectionAsHtml() As String
    
    ' offset used for concat function
    ccOffset = 0
    
    With Selection
    ' We need this base case, in order to avoid error when selecting character from
    ' collection, below
    If .Characters.Count = 0 Then
        Exit Function
    End If
    
    ' In the majority of the cases, there will be only one font, and no bold, italic, or other
    ' formatting. We want to avoid all the work of stepping through each word for these guys.
    If ThereIsNoFormatting = True Then
        GetSelectionAsHtml = GetSelectionAsHtmlSimplified
        Exit Function
    End If
    
    ' ===========================================
    ' OK THEN, LET'S ROLL UP THE OLD SLEEVES!!!
    ' ===========================================
    
    ' Keep the original range, because we may need to select individual characters
    ' due to Word's %$(@)# handling of symbols
    Dim oOriginalRange As Range
    Set oOriginalRange = Selection.Range
    
    ' keep a stack of open tags, so we prevent crossover.
    ' i.e., we want to avoid stuff like this:
    ' <b><i>Hello!</b></i>
    ' or this:
    ' <b>Hello, <i>my</b> name is Myron...</i>
    Dim TagStack As New Collection
    
    ' keep track of our current formatting
    CurrentBoldState = False
    CurrentItalicState = False
    CurrentUnderlineState = wdUnderlineNone
    CurrentForeColor = 0
    CurrentSupState = SUP_NONE
    CurrentFontName = ""
    
    ' store this in a variable in order to avoid too many function calls
    Dim BoldState As Boolean
    Dim ItalicState As Boolean
    Dim UnderlineState As Long
    Dim SupState As Long
    Dim ForeColor As Long
    Dim FontName As String
          
    Dim c As Object
    For Each c In .Characters
        
        With c.Font
            
            ' keep it to 1 function call, boys
            BoldState = .Bold
            ItalicState = .Italic
            UnderlineState = .Underline
            ForeColor = .ColorIndex
            FontName = .Name
            If .Superscript Then
                SupState = SUP_SUPER
            ElseIf .Subscript Then
                SupState = SUP_SUB
            Else
                SupState = SUP_NONE
            End If
            
            '                               '
            ' First, close off any tags     '
            '                               '
            
            ' /sup-sub
            If SupState <> CurrentSupState Then
                Select Case CurrentSupState
                    Case SUP_SUPER:
                        Concat GetSelectionAsHtml, UnwindTagStackUntil(TagStack, "</sup>")
                    Case SUP_SUB:
                        Concat GetSelectionAsHtml, UnwindTagStackUntil(TagStack, "</sub>")
                End Select
            End If
            
            ' /bold
            If BoldState = False And CurrentBoldState = True Then
                Concat GetSelectionAsHtml, UnwindTagStackUntil(TagStack, "</b>")
            End If
            ' /italic
            If ItalicState = False And CurrentItalicState = True Then
                Concat GetSelectionAsHtml, UnwindTagStackUntil(TagStack, "</i>")
            End If
            ' /underline
            If UnderlineState <> CurrentUnderlineState And CurrentUnderlineState <> wdUnderlineNone Then
                Concat GetSelectionAsHtml, UnwindTagStackUntil(TagStack, "</u>")
            End If
            ' /span
            If (CurrentForeColor <> ForeColor) And CurrentForeColor > 0 Then
                Concat GetSelectionAsHtml, UnwindTagStackUntil(TagStack, "</span>")
            End If
            ' /font
            If FontName <> CurrentFontName And CurrentFontName <> "" Then
                Concat GetSelectionAsHtml, UnwindTagStackUntil(TagStack, "</font>")
            End If
            
                                       
            '                                             '
            ' Now, apply any required formatting tags     '
            '                                             '
            
            ' font
            If FontName <> CurrentFontName Then
                CurrentFontName = FontName
                ' new format tag
                If CurrentFontName <> "" Then
                    Concat GetSelectionAsHtml, "<font face="""
                    Concat GetSelectionAsHtml, CurrentFontName
                    Concat GetSelectionAsHtml, """>"
                    Push TagStack, "</font>"
                End If
            End If
            
            ' span
            If (ForeColor <> CurrentForeColor) Then
                ' new format tag
                Concat GetSelectionAsHtml, "<span style=""color:"
                Concat GetSelectionAsHtml, ColorLong2String(ForeColor)
                Concat GetSelectionAsHtml, """>"
                
                Push TagStack, "</span>"
                CurrentForeColor = ForeColor
            End If
            
            ' underline
            If UnderlineState <> CurrentUnderlineState Then
                CurrentUnderlineState = UnderlineState
                Concat GetSelectionAsHtml, "<u>"
                Push TagStack, "</u>"
            End If
            
            ' italic
            If ItalicState <> CurrentItalicState Then
                CurrentItalicState = ItalicState
                Concat GetSelectionAsHtml, "<i>"
                Push TagStack, "</i>"
            End If
            
            ' bold
            If BoldState <> CurrentBoldState Then
                Concat GetSelectionAsHtml, "<b>"
                Push TagStack, "</b>"
                CurrentBoldState = BoldState
            End If
            
            If SupState <> CurrentSupState Then
                Select Case SupState
                    Case SUP_SUPER:
                        Concat GetSelectionAsHtml, "<sup>"
                        Push TagStack, "</sup>"
                    Case SUP_SUB:
                        Concat GetSelectionAsHtml, "<sub>"
                        Push TagStack, "</sub>"
                End Select
                CurrentSupState = SupState
            End If
        End With
        With c
            Select Case .Text
                Case "("
                    .Select
                    Concat GetSelectionAsHtml, Symbol2Unicode(Dialogs(wdDialogInsertSymbol).charnum)
                    oOriginalRange.Select
                Case "<"
                    Concat GetSelectionAsHtml, "&#60;"
                Case "&"
                    Concat GetSelectionAsHtml, "&amp;"
                Case Else
                    Concat GetSelectionAsHtml, .Text
            End Select
        End With ' with c
    Next c
    
    End With ' with selection
    
    ' Close off any open tags
    While TagStack.Count > 0
        Concat GetSelectionAsHtml, Pop(TagStack)
    Wend
        
    ' release any memory still reserved
    GetSelectionAsHtml = Left$(GetSelectionAsHtml, ccOffset)

    ' clean up
    oOriginalRange.Select
    Set oOriginalRange = Nothing
    Set TagStack = Nothing
    
End Function


'================================================
' Html2Doc                                      +
'================================================
Sub Html2Doc(HtmlString As String)

    On Error GoTo HandleError
    
    Selection.Text = ""
       
    With Selection.Font
        ' set up font state
        CurrentBoldState = .Bold
        CurrentItalicState = .Italic
        CurrentUnderlineState = .Underline
        CurrentForeColor = .ColorIndex
        CurrentFontName = .Name
        If .Superscript = True Then
            CurrentSupState = SUP_SUPER
        ElseIf .Subscript = True Then
            CurrentSupState = SUP_SUB
        Else
            CurrentSupState = SUP_NONE
        End If
    End With
    
    ' keep track of our formatting tags
    ' do formatting like this:
    ' "bold:false"
    Dim FormattingStateStack As New Collection

    ' the text
    Dim sText As String
    Dim sTag As String
        
    
    ' find the first tag marker
    sText = GetLine(HtmlString, "<")
   
    While HtmlString <> ""
           
        ReplaceHtmlTagsAndWrite sText
        sTag = GetLine(HtmlString, ">")
        
        If Left(sTag, 1) = "/" Then      ' end tag
        ' POP STATE
            FontInfoGoingOutOfScope Pop(FormattingStateStack)
        Else                                    ' start tag
        ' PUSH STATE
            Push FormattingStateStack, ParseHtmlTag(sTag)
        End If
        
        sText = GetLine(HtmlString, "<")
    Wend
    
    ReplaceHtmlTagsAndWrite sText
    
    Set FormattingStateStack = Nothing
        
    With Selection.Font
        .Bold = CurrentBoldState
        .Italic = CurrentItalicState
        .Underline = CurrentUnderlineState
        .ColorIndex = CurrentForeColor
        .Name = CurrentFontName
        If CurrentSupState <> SUP_NONE Then
            If CurrentSupState = SUP_SUPER Then
                Selection.Font.Superscript = True
            Else
                Selection.Font.Subscript = True
            End If
        End If
    End With
    
    Exit Sub
    
HandleError:

    With Selection.Font
        .Bold = CurrentBoldState
         .Italic = CurrentItalicState
         .Underline = CurrentUnderlineState
        .ColorIndex = CurrentForeColor
        .Name = CurrentFontName
        If CurrentSupState <> SUP_NONE Then
            If CurrentSupState = SUP_SUPER Then
                Selection.Font.Superscript = True
            Else
                Selection.Font.Subscript = True
            End If
        End If
    End With
    
    Set FormattingStateStack = Nothing
    ' pass up the error
    Err.Raise Err.Number
End Sub


' ======================================
' stack stuff
' ======================================

' Push
Private Sub Push(ByRef stack As Collection, ByRef element As Variant)

    If stack.Count = 0 Then
        stack.Add element
        Exit Sub
    End If
    
    stack.Add Item:=element, Before:=1

End Sub

' Pop
Private Function Pop(ByRef stack As Collection) As Variant

    Pop = stack.Item(1)
    stack.Remove 1

End Function

' ======================================
' Various helper routines below here
' ======================================

Function UnwindTagStackUntil(ByRef TagStack As Collection, StopTag As Variant) As String

    Dim Tag As String
    
    While Tag <> StopTag
        Tag = Pop(TagStack)
        Select Case Tag
            Case "</i>", "</em>"
                CurrentItalicState = False
            Case "</b>", "</strong>"
                CurrentBoldState = False
            Case "</u>"
                CurrentUnderlineState = wdUnderlineNone
            Case "</font>"
                CurrentFontName = ""
            Case "</span>"
                CurrentForeColor = 0
            Case "</sub>", "</sup>"
                CurrentSupState = SUP_NONE
        End Select
        UnwindTagStackUntil = UnwindTagStackUntil & Tag
    Wend
End Function

Function Symbol2Unicode(charcode As Long) As String

    ' base case
    If charcode = 40 Then
        Symbol2Unicode = "("
        Exit Function
    End If

      Select Case charcode + 4096
        Case &H22    ' # FOR ALL
          Symbol2Unicode = ChrW(&H2200)
        Case &H24    ' # THERE EXISTS
          Symbol2Unicode = ChrW(&H2203)
        Case &H27    ' # CONTAINS AS MEMBER
          Symbol2Unicode = ChrW(&H220B)
        Case &H2A    ' # ASTERISK OPERATOR
          Symbol2Unicode = ChrW(&H2217)
        Case &H2D    ' # MINUS SIGN
          Symbol2Unicode = ChrW(&H2212)
        Case &H40    ' # APPROXIMATELY EQUAL TO
          Symbol2Unicode = ChrW(&H2245)
        Case &H41    ' # GREEK CAPITAL LETTER ALPHA
          Symbol2Unicode = ChrW(&H391)
        Case &H42    ' # GREEK CAPITAL LETTER BETA
          Symbol2Unicode = ChrW(&H392)
        Case &H43    ' # GREEK CAPITAL LETTER CHI
          Symbol2Unicode = ChrW(&H3A7)
        Case &H44    ' # GREEK CAPITAL LETTER DELTA
          Symbol2Unicode = ChrW(&H394)
        Case &H44    ' # INCREMENT
          Symbol2Unicode = ChrW(&H2206)
        Case &H45    ' # GREEK CAPITAL LETTER EPSILON
          Symbol2Unicode = ChrW(&H395)
        Case &H46    ' # GREEK CAPITAL LETTER PHI
          Symbol2Unicode = ChrW(&H3A6)
        Case &H47    ' # GREEK CAPITAL LETTER GAMMA
          Symbol2Unicode = ChrW(&H393)
        Case &H48    ' # GREEK CAPITAL LETTER ETA
          Symbol2Unicode = ChrW(&H397)
        Case &H49    ' # GREEK CAPITAL LETTER IOTA
          Symbol2Unicode = ChrW(&H399)
        Case &H4A    ' # GREEK THETA SYMBOL
          Symbol2Unicode = ChrW(&H3D1)
        Case &H4B    ' # GREEK CAPITAL LETTER KAPPA
          Symbol2Unicode = ChrW(&H39A)
        Case &H4C    ' # GREEK CAPITAL LETTER LAMDA
          Symbol2Unicode = ChrW(&H39B)
        Case &H4D    ' # GREEK CAPITAL LETTER MU
          Symbol2Unicode = ChrW(&H39C)
        Case &H4E    ' # GREEK CAPITAL LETTER NU
          Symbol2Unicode = ChrW(&H39D)
        Case &H4F    ' # GREEK CAPITAL LETTER OMICRON
          Symbol2Unicode = ChrW(&H39F)
        Case &H50    ' # GREEK CAPITAL LETTER PI
          Symbol2Unicode = ChrW(&H3A0)
        Case &H51    ' # GREEK CAPITAL LETTER THETA
          Symbol2Unicode = ChrW(&H398)
        Case &H52    ' # GREEK CAPITAL LETTER RHO
          Symbol2Unicode = ChrW(&H3A1)
        Case &H53    ' # GREEK CAPITAL LETTER SIGMA
          Symbol2Unicode = ChrW(&H3A3)
        Case &H54    ' # GREEK CAPITAL LETTER TAU
          Symbol2Unicode = ChrW(&H3A4)
        Case &H55    ' # GREEK CAPITAL LETTER UPSILON
          Symbol2Unicode = ChrW(&H3A5)
        Case &H56    ' # GREEK SMALL LETTER FINAL SIGMA
          Symbol2Unicode = ChrW(&H3C2)
        Case &H57    ' # GREEK CAPITAL LETTER OMEGA
          Symbol2Unicode = ChrW(&H3A9)
        Case &H57    ' # OHM SIGN
          Symbol2Unicode = ChrW(&H2126)
        Case &H58    ' # GREEK CAPITAL LETTER XI
          Symbol2Unicode = ChrW(&H39E)
        Case &H59    ' # GREEK CAPITAL LETTER PSI
          Symbol2Unicode = ChrW(&H3A8)
        Case &H5A    ' # GREEK CAPITAL LETTER ZETA
          Symbol2Unicode = ChrW(&H396)
        Case &H5C    ' # THEREFORE
          Symbol2Unicode = ChrW(&H2234)
        Case &H5E    ' # UP TACK
          Symbol2Unicode = ChrW(&H22A5)
        Case &H60    ' # RADICAL EXTENDER
          Symbol2Unicode = ChrW(&HF8E5)
        Case &H61    ' # GREEK SMALL LETTER ALPHA
          Symbol2Unicode = ChrW(&H3B1)
        Case &H62    ' # GREEK SMALL LETTER BETA
          Symbol2Unicode = ChrW(&H3B2)
        Case &H63    ' # GREEK SMALL LETTER CHI
          Symbol2Unicode = ChrW(&H3C7)
        Case &H64    ' # GREEK SMALL LETTER DELTA
          Symbol2Unicode = ChrW(&H3B4)
        Case &H65    ' # GREEK SMALL LETTER EPSILON
          Symbol2Unicode = ChrW(&H3B5)
        Case &H66    ' # GREEK SMALL LETTER PHI
          Symbol2Unicode = ChrW(&H3C6)
        Case &H67    ' # GREEK SMALL LETTER GAMMA
          Symbol2Unicode = ChrW(&H3B3)
        Case &H68    ' # GREEK SMALL LETTER ETA
          Symbol2Unicode = ChrW(&H3B7)
        Case &H69    ' # GREEK SMALL LETTER IOTA
          Symbol2Unicode = ChrW(&H3B9)
        Case &H6A    ' # GREEK PHI SYMBOL
          Symbol2Unicode = ChrW(&H3D5)
        Case &H6B    ' # GREEK SMALL LETTER KAPPA
          Symbol2Unicode = ChrW(&H3BA)
        Case &H6C    ' # GREEK SMALL LETTER LAMDA
          Symbol2Unicode = ChrW(&H3BB)
        Case &H6D    ' # MICRO SIGN
          Symbol2Unicode = ChrW(&HB5)
        Case &H6D    ' # GREEK SMALL LETTER MU
          Symbol2Unicode = ChrW(&H3BC)
        Case &H6E    ' # GREEK SMALL LETTER NU
          Symbol2Unicode = ChrW(&H3BD)
        Case &H6F    ' # GREEK SMALL LETTER OMICRON
          Symbol2Unicode = ChrW(&H3BF)
        Case &H70    ' # GREEK SMALL LETTER PI
          Symbol2Unicode = ChrW(&H3C0)
        Case &H71    ' # GREEK SMALL LETTER THETA
          Symbol2Unicode = ChrW(&H3B8)
        Case &H72    ' # GREEK SMALL LETTER RHO
          Symbol2Unicode = ChrW(&H3C1)
        Case &H73    ' # GREEK SMALL LETTER SIGMA
          Symbol2Unicode = ChrW(&H3C3)
        Case &H74    ' # GREEK SMALL LETTER TAU
          Symbol2Unicode = ChrW(&H3C4)
        Case &H75    ' # GREEK SMALL LETTER UPSILON
          Symbol2Unicode = ChrW(&H3C5)
        Case &H76    ' # GREEK PI SYMBOL
          Symbol2Unicode = ChrW(&H3D6)
        Case &H77    ' # GREEK SMALL LETTER OMEGA
          Symbol2Unicode = ChrW(&H3C9)
        Case &H78    ' # GREEK SMALL LETTER XI
          Symbol2Unicode = ChrW(&H3BE)
        Case &H79    ' # GREEK SMALL LETTER PSI
          Symbol2Unicode = ChrW(&H3C8)
        Case &H7A    ' # GREEK SMALL LETTER ZETA
          Symbol2Unicode = ChrW(&H3B6)
        Case &H7E    ' # TILDE OPERATOR
          Symbol2Unicode = ChrW(&H223C)
        Case &HA0    ' # EURO SIGN
          Symbol2Unicode = ChrW(&H20AC)
        Case &HA1    ' # GREEK UPSILON WITH HOOK SYMBOL
          Symbol2Unicode = ChrW(&H3D2)
        Case &HA2    ' # PRIME
          Symbol2Unicode = ChrW(&H2032)
        Case &HA3    ' # LESS-THAN OR EQUAL TO
          Symbol2Unicode = ChrW(&H2264)
        Case &HA4    ' # FRACTION SLASH
          Symbol2Unicode = ChrW(&H2044)
        Case &HA4    ' # DIVISION SLASH
          Symbol2Unicode = ChrW(&H2215)
        Case &HA5    ' # INFINITY
          Symbol2Unicode = ChrW(&H221E)
        Case &HA6    ' # LATIN SMALL LETTER F WITH HOOK
          Symbol2Unicode = ChrW(&H192)
        Case &HA7    ' # BLACK CLUB SUIT
          Symbol2Unicode = ChrW(&H2663)
        Case &HA8    ' # BLACK DIAMOND SUIT
          Symbol2Unicode = ChrW(&H2666)
        Case &HA9    ' # BLACK HEART SUIT
          Symbol2Unicode = ChrW(&H2665)
        Case &HAA    ' # BLACK SPADE SUIT
          Symbol2Unicode = ChrW(&H2660)
        Case &HAB    ' # LEFT RIGHT ARROW
          Symbol2Unicode = ChrW(&H2194)
        Case &HAC    ' # LEFTWARDS ARROW
          Symbol2Unicode = ChrW(&H2190)
        Case &HAD    ' # UPWARDS ARROW
          Symbol2Unicode = ChrW(&H2191)
        Case &HAE    ' # RIGHTWARDS ARROW
          Symbol2Unicode = ChrW(&H2192)
        Case &HAF    ' # DOWNWARDS ARROW
          Symbol2Unicode = ChrW(&H2193)
        Case &HB2    ' # DOUBLE PRIME
          Symbol2Unicode = ChrW(&H2033)
        Case &HB3    ' # GREATER-THAN OR EQUAL TO
          Symbol2Unicode = ChrW(&H2265)
        Case &HB4    ' # MULTIPLICATION SIGN
          Symbol2Unicode = ChrW(&HD7)
        Case &HB5    ' # PROPORTIONAL TO
          Symbol2Unicode = ChrW(&H221D)
        Case &HB6    ' # PARTIAL DIFFERENTIAL
          Symbol2Unicode = ChrW(&H2202)
        Case &HB7    ' # BULLET
          Symbol2Unicode = ChrW(&H2022)
        Case &HB8    ' # DIVISION SIGN
          Symbol2Unicode = ChrW(&HF7)
        Case &HB9    ' # NOT EQUAL TO
          Symbol2Unicode = ChrW(&H2260)
        Case &HBA    ' # IDENTICAL TO
          Symbol2Unicode = ChrW(&H2261)
        Case &HBB    ' # ALMOST EQUAL TO
          Symbol2Unicode = ChrW(&H2248)
        Case &HBC    ' # HORIZONTAL ELLIPSIS
          Symbol2Unicode = ChrW(&H2026)
        Case &HBD    ' # VERTICAL ARROW EXTENDER
          Symbol2Unicode = ChrW(&HF8E6)
        Case &HBE    ' # HORIZONTAL ARROW EXTENDER
          Symbol2Unicode = ChrW(&HF8E7)
        Case &HBF    ' # DOWNWARDS ARROW WITH CORNER LEFTWARDS
          Symbol2Unicode = ChrW(&H21B5)
        Case &HC0    ' # ALEF SYMBOL
          Symbol2Unicode = ChrW(&H2135)
        Case &HC1    ' # BLACK-LETTER CAPITAL I
          Symbol2Unicode = ChrW(&H2111)
        Case &HC2    ' # BLACK-LETTER CAPITAL R
          Symbol2Unicode = ChrW(&H211C)
        Case &HC3    ' # SCRIPT CAPITAL P
          Symbol2Unicode = ChrW(&H2118)
        Case &HC4    ' # CIRCLED TIMES
          Symbol2Unicode = ChrW(&H2297)
        Case &HC5    ' # CIRCLED PLUS
          Symbol2Unicode = ChrW(&H2295)
        Case &HC6    ' # EMPTY SET
          Symbol2Unicode = ChrW(&H2205)
        Case &HC7    ' # INTERSECTION
          Symbol2Unicode = ChrW(&H2229)
        Case &HC8    ' # UNION
          Symbol2Unicode = ChrW(&H222A)
        Case &HC9    ' # SUPERSET OF
          Symbol2Unicode = ChrW(&H2283)
        Case &HCA    ' # SUPERSET OF OR EQUAL TO
          Symbol2Unicode = ChrW(&H2287)
        Case &HCB    ' # NOT A SUBSET OF
          Symbol2Unicode = ChrW(&H2284)
        Case &HCC    ' # SUBSET OF
          Symbol2Unicode = ChrW(&H2282)
        Case &HCD    ' # SUBSET OF OR EQUAL TO
          Symbol2Unicode = ChrW(&H2286)
        Case &HCE    ' # ELEMENT OF
          Symbol2Unicode = ChrW(&H2208)
        Case &HCF    ' # NOT AN ELEMENT OF
          Symbol2Unicode = ChrW(&H2209)
        Case &HD0    ' # ANGLE
          Symbol2Unicode = ChrW(&H2220)
        Case &HD1    ' # NABLA
          Symbol2Unicode = ChrW(&H2207)
        Case &HD2    ' # REGISTERED SIGN SERIF
          Symbol2Unicode = ChrW(&HF6DA)
        Case &HD3    ' # COPYRIGHT SIGN SERIF
          Symbol2Unicode = ChrW(&HF6D9)
        Case &HD4    ' # TRADE MARK SIGN SERIF
          Symbol2Unicode = ChrW(&HF6DB)
        Case &HD5    ' # N-ARY PRODUCT
          Symbol2Unicode = ChrW(&H220F)
        Case &HD6    ' # SQUARE ROOT
          Symbol2Unicode = ChrW(&H221A)
        Case &HD7    ' # DOT OPERATOR
          Symbol2Unicode = ChrW(&H22C5)
        Case &HD8    ' # NOT SIGN
          Symbol2Unicode = ChrW(&HAC)
        Case &HD9    ' # LOGICAL AND
          Symbol2Unicode = ChrW(&H2227)
        Case &HDA    ' # LOGICAL OR
          Symbol2Unicode = ChrW(&H2228)
        Case &HDB    ' # LEFT RIGHT DOUBLE ARROW
          Symbol2Unicode = ChrW(&H21D4)
        Case &HDC    ' # LEFTWARDS DOUBLE ARROW
          Symbol2Unicode = ChrW(&H21D0)
        Case &HDD    ' # UPWARDS DOUBLE ARROW
          Symbol2Unicode = ChrW(&H21D1)
        Case &HDE    ' # RIGHTWARDS DOUBLE ARROW
          Symbol2Unicode = ChrW(&H21D2)
        Case &HDF    ' # DOWNWARDS DOUBLE ARROW
          Symbol2Unicode = ChrW(&H21D3)
        Case &HE0    ' # LOZENGE
          Symbol2Unicode = ChrW(&H25CA)
        Case &HE1    ' # LEFT-POINTING ANGLE BRACKET
          Symbol2Unicode = ChrW(&H2329)
        Case &HE2    ' # REGISTERED SIGN SANS SERIF
          Symbol2Unicode = ChrW(&HF8E8)
        Case &HE3    ' # COPYRIGHT SIGN SANS SERIF
          Symbol2Unicode = ChrW(&HF8E9)
        Case &HE4    ' # TRADE MARK SIGN SANS SERIF
          Symbol2Unicode = ChrW(&HF8EA)
        Case &HE5    ' # N-ARY SUMMATION
          Symbol2Unicode = ChrW(&H2211)
        Case &HE6    ' # LEFT PAREN TOP
          Symbol2Unicode = ChrW(&HF8EB)
        Case &HE7    ' # LEFT PAREN EXTENDER
          Symbol2Unicode = ChrW(&HF8EC)
        Case &HE8    ' # LEFT PAREN BOTTOM
          Symbol2Unicode = ChrW(&HF8ED)
        Case &HE9    ' # LEFT SQUARE BRACKET TOP
          Symbol2Unicode = ChrW(&HF8EE)
        Case &HEA    ' # LEFT SQUARE BRACKET EXTENDER
          Symbol2Unicode = ChrW(&HF8EF)
        Case &HEB    ' # LEFT SQUARE BRACKET BOTTOM
          Symbol2Unicode = ChrW(&HF8F0)
        Case &HEC    ' # LEFT CURLY BRACKET TOP
          Symbol2Unicode = ChrW(&HF8F1)
        Case &HED    ' # LEFT CURLY BRACKET MID
          Symbol2Unicode = ChrW(&HF8F2)
        Case &HEE    ' # LEFT CURLY BRACKET BOTTOM
          Symbol2Unicode = ChrW(&HF8F3)
        Case &HEF    ' # CURLY BRACKET EXTENDER
          Symbol2Unicode = ChrW(&HF8F4)
        Case &HF1    ' # RIGHT-POINTING ANGLE BRACKET
          Symbol2Unicode = ChrW(&H232A)
        Case &HF2    ' # INTEGRAL
          Symbol2Unicode = ChrW(&H222B)
        Case &HF3    ' # TOP HALF INTEGRAL
          Symbol2Unicode = ChrW(&H2320)
        Case &HF4    ' # INTEGRAL EXTENDER
          Symbol2Unicode = ChrW(&HF8F5)
        Case &HF5    ' # BOTTOM HALF INTEGRAL
          Symbol2Unicode = ChrW(&H2321)
        Case &HF6    ' # RIGHT PAREN TOP
          Symbol2Unicode = ChrW(&HF8F6)
        Case &HF7    ' # RIGHT PAREN EXTENDER
          Symbol2Unicode = ChrW(&HF8F7)
        Case &HF8    ' # RIGHT PAREN BOTTOM
          Symbol2Unicode = ChrW(&HF8F8)
        Case &HF9    ' # RIGHT SQUARE BRACKET TOP
          Symbol2Unicode = ChrW(&HF8F9)
        Case &HFA    ' # RIGHT SQUARE BRACKET EXTENDER
          Symbol2Unicode = ChrW(&HF8FA)
        Case &HFB    ' # RIGHT SQUARE BRACKET BOTTOM
          Symbol2Unicode = ChrW(&HF8FB)
        Case &HFC    ' # RIGHT CURLY BRACKET TOP
          Symbol2Unicode = ChrW(&HF8FC)
        Case &HFD    ' # RIGHT CURLY BRACKET MID
          Symbol2Unicode = ChrW(&HF8FD)
        Case &HFE    ' # RIGHT CURLY BRACKET BOTTOM
          Symbol2Unicode = ChrW(&HF8FE)
        Case Else ' punt
            Symbol2Unicode = ChrW(charcode)
      End Select
 
End Function

Function GetSelectionAsHtmlSimplified() As String

    ' keep a stack of open tags, so we prevent crossover.
    ' i.e., we want to avoid stuff like this:
    ' <b><i>Hello!</b></i>
    ' or this:
    ' <b>Hello, <i>my</b> name is Myron...</i>
    Dim TagStack As New Collection
    
    ' keep original range
    Dim oOriginalRange As Range
    Set oOriginalRange = Selection.Range
    
    '  -------->
    With Selection.Font
        
       
        Concat GetSelectionAsHtmlSimplified, "<font face="""
        Concat GetSelectionAsHtmlSimplified, .Name
        Concat GetSelectionAsHtmlSimplified, """>"
        Push TagStack, "</font>"
           
        ' underline
        If .Underline <> wdUnderlineNone Then
            Concat GetSelectionAsHtmlSimplified, "<u>"
            Push TagStack, "</u>"
        End If
        ' italic
        If .Italic = True Then
            Concat GetSelectionAsHtmlSimplified, "<i>"
            Push TagStack, "</i>"
        End If
        ' bold
        If .Bold = True Then
            Concat GetSelectionAsHtmlSimplified, "<b>"
            Push TagStack, "</b>"
        End If
        
        ' color
        If (.ColorIndex > 0) Then
                    
            Concat GetSelectionAsHtmlSimplified, "<span style=""color:"
            Concat GetSelectionAsHtmlSimplified, ColorLong2String(.ColorIndex)
            Concat GetSelectionAsHtmlSimplified, """>"
            
            Push TagStack, "</span>"
        End If

        If .Subscript = True Then
            Concat GetSelectionAsHtmlSimplified, "<sub>"
            
            Push TagStack, "</sub>"
        ElseIf .Superscript = True Then
            Concat GetSelectionAsHtmlSimplified, "<sup>"
            
            Push TagStack, "</sup>"
        End If

    End With ' <---------- with selection.font
    
    ' Now, add the text
    
    '  -------->
    With Selection
    
        Dim pos As Long
        Dim ParenPos As Long
        Dim AngleBracketPos As Long
        Dim AmpersandPos As Long
        
        Dim UnicodeSymbol As String
    
        pos = 1
        ParenPos = InStr(pos, .Text, "(")
        AngleBracketPos = InStr(pos, .Text, "<")
        AmpersandPos = InStr(pos, .Text, "&")
         
        While ParenPos > 0 Or AngleBracketPos > 0 Or AmpersandPos > 0
            ' (
            If ParenPos > 0 And (ParenPos < AngleBracketPos Or AngleBracketPos = 0) And (ParenPos < AmpersandPos Or AmpersandPos = 0) Then
                .Characters(ParenPos).Select
                UnicodeSymbol = Symbol2Unicode(Dialogs(wdDialogInsertSymbol).charnum)
                oOriginalRange.Select
                Concat GetSelectionAsHtmlSimplified, Mid(.Text, pos, ParenPos - pos)
                Concat GetSelectionAsHtmlSimplified, UnicodeSymbol
                pos = ParenPos + 1
            ' &
            ElseIf AmpersandPos > 0 And (AmpersandPos < AngleBracketPos Or AngleBracketPos = 0) Then
                Concat GetSelectionAsHtmlSimplified, Mid(.Text, pos, AmpersandPos - pos)
                Concat GetSelectionAsHtmlSimplified, "&amp;"
                pos = AmpersandPos + 1
            ' <
            Else ' ( and & not found, or < is in front of them
                Concat GetSelectionAsHtmlSimplified, Mid(.Text, pos, AngleBracketPos - pos)
                Concat GetSelectionAsHtmlSimplified, "&lt;"
                pos = AngleBracketPos + 1
            End If
            
            ParenPos = InStr(pos, .Text, "(")
            AngleBracketPos = InStr(pos, .Text, "<")
            AmpersandPos = InStr(pos, .Text, "&")
        Wend
        
        Concat GetSelectionAsHtmlSimplified, Mid(.Text, pos)

    End With ' selection
    
    ' Close off any open tags
    While TagStack.Count > 0
        Concat GetSelectionAsHtmlSimplified, Pop(TagStack)
    Wend
        
    ' release any memory still reserved
    GetSelectionAsHtmlSimplified = Left$(GetSelectionAsHtmlSimplified, ccOffset)
    
    ' clean up
    Set TagStack = Nothing
    Set oOriginalRange = Nothing

End Function

Function ThereIsNoFormatting() As Boolean
    With Selection.Font
        If .Name <> "" Then ' It will be an empty string only if there is more than 1 font
            If .Bold <> wdUndefined Then ' it will be wdUndefined if there is a mixture of bold/plain
                If .Italic <> wdUndefined Then  ' ditto
                    If .Underline <> wdUndefined Then  ' ditto 2
                        If .ColorIndex <> wdUndefined Then ' nope, no formatting!
                            If .Subscript <> wdUndefined And .Superscript <> wdUndefined Then ' no sub or superscript
                                ThereIsNoFormatting = True
                                Exit Function
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End With ' with selection.font
End Function


Sub ReplaceHtmlTagsAndWrite(HtmlString As String)

    Dim pos As Long
    
    If HtmlString = "" Then
        Exit Sub
    End If
    
    pos = InStr(1, HtmlString, "&")
    
    With Selection
    
       
    While pos > 0
        ' write text up to the &
        .TypeText Left(HtmlString, pos - 1)
        ' get rest of HtmlString after &
        HtmlString = Mid(HtmlString, pos + 1)
        ' get length from code to ;
        If Left(HtmlString, 1) = "#" Then ' cool, just convert the char code to a unicode char
            pos = InStr(1, HtmlString, ";")
            ' turn the numeric tag into unicode
            .Text = ChrW(CLng(Mid(HtmlString, 2, pos - 2)))
            .Collapse wdCollapseEnd
        Else ' drat, it's an ascii string. We have to look it up
            pos = InStr(1, HtmlString, ";")
            .Text = Html2Unicode(Left(HtmlString, pos - 1))
            .Collapse wdCollapseEnd
        End If
        ' get the rest of the HtmlString after we ate the html tag
        HtmlString = Mid(HtmlString, pos + 1)
        ' look for the next &
        pos = InStr(1, HtmlString, "&")
    Wend
    
    ' write the rest of the HtmlString
    If HtmlString <> "" Then
        .TypeText HtmlString
        .Collapse wdCollapseEnd
    End If
    
    End With
        
End Sub

Function Html2Unicode(HtmlTag As String) As String

    Select Case HtmlTag
        Case "nbsp"
            Html2Unicode = " "
        Case "amp"
            Html2Unicode = "&"
        Case "lt"
            Html2Unicode = "<"
        Case "forall"    ' # FOR ALL
          Html2Unicode = ChrW(&H2200)
        Case "exist"    ' # THERE EXISTS
          Html2Unicode = ChrW(&H2203)
        Case "ni"    ' # CONTAINS AS MEMBER
          Html2Unicode = ChrW(&H220B)
        Case "lowast"    ' # ASTERISK OPERATOR
          Html2Unicode = ChrW(&H2217)
        Case "minus"    ' # MINUS SIGN
          Html2Unicode = ChrW(&H2212)
        Case "cong"    ' # APPROXIMATELY EQUAL TO
          Html2Unicode = ChrW(&H2245)
        Case "Alpha"    ' # GREEK CAPITAL LETTER ALPHA
          Html2Unicode = ChrW(&H391)
        Case "Beta"    ' # GREEK CAPITAL LETTER BETA
          Html2Unicode = ChrW(&H392)
        Case "Chi"    ' # GREEK CAPITAL LETTER CHI
          Html2Unicode = ChrW(&H3A7)
        Case "Delta"    ' # GREEK CAPITAL LETTER DELTA
          Html2Unicode = ChrW(&H394)
        Case "x2206"    ' # INCREMENT
          Html2Unicode = ChrW(&H2206)
        Case "epsilon"    ' # GREEK CAPITAL LETTER EPSILON
          Html2Unicode = ChrW(&H395)
        Case "Phi"    ' # GREEK CAPITAL LETTER PHI
          Html2Unicode = ChrW(&H3A6)
        Case "Gamma"    ' # GREEK CAPITAL LETTER GAMMA
          Html2Unicode = ChrW(&H393)
        Case "Eta"    ' # GREEK CAPITAL LETTER ETA
          Html2Unicode = ChrW(&H397)
        Case "Iota"    ' # GREEK CAPITAL LETTER IOTA
          Html2Unicode = ChrW(&H399)
        Case "Theta"    ' # GREEK THETA SYMBOL
          Html2Unicode = ChrW(&H3D1)
        Case "Kappa"    ' # GREEK CAPITAL LETTER KAPPA
          Html2Unicode = ChrW(&H39A)
        Case "Lambda"    ' # GREEK CAPITAL LETTER LAMDA
          Html2Unicode = ChrW(&H39B)
        Case "Mu"    ' # GREEK CAPITAL LETTER MU
          Html2Unicode = ChrW(&H39C)
        Case "Nu"    ' # GREEK CAPITAL LETTER NU
          Html2Unicode = ChrW(&H39D)
        Case "Omicron"    ' # GREEK CAPITAL LETTER OMICRON
          Html2Unicode = ChrW(&H39F)
        Case "Pi"    ' # GREEK CAPITAL LETTER PI
          Html2Unicode = ChrW(&H3A0)
        Case "Theta"    ' # GREEK CAPITAL LETTER THETA
          Html2Unicode = ChrW(&H398)
        Case "Rho"    ' # GREEK CAPITAL LETTER RHO
          Html2Unicode = ChrW(&H3A1)
        Case "Sigma"    ' # GREEK CAPITAL LETTER SIGMA
          Html2Unicode = ChrW(&H3A3)
        Case "Tau"    ' # GREEK CAPITAL LETTER TAU
          Html2Unicode = ChrW(&H3A4)
        Case "Upsilon"    ' # GREEK CAPITAL LETTER UPSILON
          Html2Unicode = ChrW(&H3A5)
        Case "Sigma"    ' # GREEK SMALL LETTER FINAL SIGMA
          Html2Unicode = ChrW(&H3C2)
        Case "Omega"    ' # GREEK CAPITAL LETTER OMEGA
          Html2Unicode = ChrW(&H3A9)
        Case "Ohm", "ohm"    ' # OHM SIGN
          Html2Unicode = ChrW(&H2126)
        Case "Xi"    ' # GREEK CAPITAL LETTER XI
          Html2Unicode = ChrW(&H39E)
        Case "Psi"    ' # GREEK CAPITAL LETTER PSI
          Html2Unicode = ChrW(&H3A8)
        Case "Zeta"   ' # GREEK CAPITAL LETTER ZETA
          Html2Unicode = ChrW(&H396)
        Case "there4", "therefore"    ' # THEREFORE
          Html2Unicode = ChrW(&H2234)
        Case "bottom"    ' # UP TACK
          Html2Unicode = ChrW(&H22A5)
        Case "radicalex"    ' # RADICAL EXTENDER
          Html2Unicode = ChrW(&HF8E5)
        Case "alpha"    ' # GREEK SMALL LETTER ALPHA
          Html2Unicode = ChrW(&H3B1)
        Case "beta"    ' # GREEK SMALL LETTER BETA
          Html2Unicode = ChrW(&H3B2)
        Case "chi"    ' # GREEK SMALL LETTER CHI
          Html2Unicode = ChrW(&H3C7)
        Case "delta"    ' # GREEK SMALL LETTER DELTA
          Html2Unicode = ChrW(&H3B4)
        Case "epsilon"    ' # GREEK SMALL LETTER EPSILON
          Html2Unicode = ChrW(&H3B5)
        Case "phi"    ' # GREEK SMALL LETTER PHI
          Html2Unicode = ChrW(&H3C6)
        Case "gamma"    ' # GREEK SMALL LETTER GAMMA
          Html2Unicode = ChrW(&H3B3)
        Case "eta"    ' # GREEK SMALL LETTER ETA
          Html2Unicode = ChrW(&H3B7)
        Case "iota"    ' # GREEK SMALL LETTER IOTA
          Html2Unicode = ChrW(&H3B9)
        Case "phi"  ' # GREEK PHI SYMBOL
          Html2Unicode = ChrW(&H3D5)
        Case "kappa"    ' # GREEK SMALL LETTER KAPPA
          Html2Unicode = ChrW(&H3BA)
        Case "lambda"    ' # GREEK SMALL LETTER LAMDA
          Html2Unicode = ChrW(&H3BB)
        Case "mu"    ' # MICRO SIGN
          Html2Unicode = ChrW(&HB5)
        Case "mgr"    ' # GREEK SMALL LETTER MU
          Html2Unicode = ChrW(&H3BC)
        Case "ngr", "nu"    ' # GREEK SMALL LETTER NU
          Html2Unicode = ChrW(&H3BD)
        Case "omicron"    ' # GREEK SMALL LETTER OMICRON
          Html2Unicode = ChrW(&H3BF)
        Case "pi"    ' # GREEK SMALL LETTER PI
          Html2Unicode = ChrW(&H3C0)
        Case "theta"    ' # GREEK SMALL LETTER THETA
          Html2Unicode = ChrW(&H3B8)
        Case "rho"    ' # GREEK SMALL LETTER RHO
          Html2Unicode = ChrW(&H3C1)
        Case "sigma"    ' # GREEK SMALL LETTER SIGMA
          Html2Unicode = ChrW(&H3C3)
        Case "tau"    ' # GREEK SMALL LETTER TAU
          Html2Unicode = ChrW(&H3C4)
        Case "upsilon"    ' # GREEK SMALL LETTER UPSILON
          Html2Unicode = ChrW(&H3C5)
        Case "Pgr"    ' # GREEK PI SYMBOL
          Html2Unicode = ChrW(&H3D6)
        Case "omega"    ' # GREEK SMALL LETTER OMEGA
          Html2Unicode = ChrW(&H3C9)
        Case "xi"    ' # GREEK SMALL LETTER XI
          Html2Unicode = ChrW(&H3BE)
        Case "psi"    ' # GREEK SMALL LETTER PSI
          Html2Unicode = ChrW(&H3C8)
        Case "zeta"    ' # GREEK SMALL LETTER ZETA
          Html2Unicode = ChrW(&H3B6)
        Case "thksim", "sim"    ' # TILDE OPERATOR"
          Html2Unicode = ChrW(&H223C)
        Case "euro"    ' # EURO SIGN
          Html2Unicode = ChrW(&H20AC)
        Case "upsih"    ' # GREEK UPSILON WITH HOOK SYMBOL"
          Html2Unicode = ChrW(&H3D2)
        Case "prime"    ' # PRIME
          Html2Unicode = ChrW(&H2032)
        Case "le"    ' # LESS-THAN OR EQUAL TO
          Html2Unicode = ChrW(&H2264)
        Case "frasl"    ' # FRACTION SLASH
          Html2Unicode = ChrW(&H2044)
        Case "fraction"    ' # DIVISION SLASH
          Html2Unicode = ChrW(&H2215)
        Case "infin"    ' # INFINITY
          Html2Unicode = ChrW(&H221E)
        Case "fnof"    ' # LATIN SMALL LETTER F WITH HOOK
          Html2Unicode = ChrW(&H192)
        Case "clubs"    ' # BLACK CLUB SUIT"
          Html2Unicode = ChrW(&H2663)
        Case "hearts"    ' # BLACK DIAMOND SUIT
          Html2Unicode = ChrW(&H2666)
        Case "diams"    ' # BLACK HEART SUIT
          Html2Unicode = ChrW(&H2665)
        Case "spades"    ' # BLACK SPADE SUIT
          Html2Unicode = ChrW(&H2660)
        Case "harr"    ' # LEFT RIGHT ARROW
          Html2Unicode = ChrW(&H2194)
        Case "larr"    ' # LEFTWARDS ARROW
          Html2Unicode = ChrW(&H2190)
        Case "uarr"    ' # UPWARDS ARROW
          Html2Unicode = ChrW(&H2191)
        Case "rarr"    ' # RIGHTWARDS ARROW
          Html2Unicode = ChrW(&H2192)
        Case "darr"    ' # DOWNWARDS ARROW
          Html2Unicode = ChrW(&H2193)
        Case "Prime"    ' # DOUBLE PRIME"
          Html2Unicode = ChrW(&H2033)
        Case "ge"    ' # GREATER-THAN OR EQUAL TO
          Html2Unicode = ChrW(&H2265)
        Case "times"    ' # MULTIPLICATION SIGN
          Html2Unicode = ChrW(&HD7)
        Case "prop"    ' # PROPORTIONAL TO
          Html2Unicode = ChrW(&H221D)
        Case "part"    ' # PARTIAL DIFFERENTIAL
          Html2Unicode = ChrW(&H2202)
        Case "bull"    ' # BULLET
          Html2Unicode = ChrW(&H2022)
        Case "divide"    ' # DIVISION SIGN
          Html2Unicode = ChrW(&HF7)
        Case "ne"    ' # NOT EQUAL TO
          Html2Unicode = ChrW(&H2260)
        Case "equiv"    ' # IDENTICAL TO
          Html2Unicode = ChrW(&H2261)
        Case "asymp"    ' # ALMOST EQUAL TO
          Html2Unicode = ChrW(&H2248)
        Case "hellip"    ' # HORIZONTAL ELLIPSIS
          Html2Unicode = ChrW(&H2026)
        Case "arrowvertex"    ' # VERTICAL ARROW EXTENDER
          Html2Unicode = ChrW(&HF8E6)
        Case "arrowhorizex"    ' # HORIZONTAL ARROW EXTENDER
          Html2Unicode = ChrW(&HF8E7)
        Case "carriagereturn"    ' # DOWNWARDS ARROW WITH CORNER LEFTWARDS
          Html2Unicode = ChrW(&H21B5)
        Case "aleph"    ' # ALEF SYMBOL
          Html2Unicode = ChrW(&H2135)
        Case "Ifractur"    ' # BLACK-LETTER CAPITAL I
          Html2Unicode = ChrW(&H2111)
        Case "Rfractur"    ' # BLACK-LETTER CAPITAL R
          Html2Unicode = ChrW(&H211C)
        Case "weierstrass"    ' # SCRIPT CAPITAL P
          Html2Unicode = ChrW(&H2118)
        Case "circlemultiply"    ' # CIRCLED TIMES
          Html2Unicode = ChrW(&H2297)
        Case "circleplus"    ' # CIRCLED PLUS
          Html2Unicode = ChrW(&H2295)
        Case "emptyset"    ' # EMPTY SET
          Html2Unicode = ChrW(&H2205)
        Case "intersection"    ' # INTERSECTION
          Html2Unicode = ChrW(&H2229)
        Case "cup"    ' # UNION
          Html2Unicode = ChrW(&H222A)
        Case "sup"    ' # SUPERSET OF
          Html2Unicode = ChrW(&H2283)
        Case "supe"    ' # SUPERSET OF OR EQUAL TO
          Html2Unicode = ChrW(&H2287)
        Case "nsub"    ' # NOT A SUBSET OF
          Html2Unicode = ChrW(&H2284)
        Case "sub"    ' # SUBSET OF
          Html2Unicode = ChrW(&H2282)
        Case "sube"    ' # SUBSET OF OR EQUAL TO
          Html2Unicode = ChrW(&H2286)
        Case "isin"    ' # ELEMENT OF
          Html2Unicode = ChrW(&H2208)
        Case "notin"    ' # NOT AN ELEMENT OF
          Html2Unicode = ChrW(&H2209)
        Case "ang"    ' # ANGLE
          Html2Unicode = ChrW(&H2220)
        Case "nabla"    ' # NABLA
          Html2Unicode = ChrW(&H2207)
        Case "registerserif"    ' # REGISTERED SIGN SERIF
          Html2Unicode = ChrW(&HF6DA)
        Case "copyrightserif"    ' # COPYRIGHT SIGN SERIF
          Html2Unicode = ChrW(&HF6D9)
        Case "trademarkserif"    ' # TRADE MARK SIGN SERIF
          Html2Unicode = ChrW(&HF6DB)
        Case "product"    ' # N-ARY PRODUCT
          Html2Unicode = ChrW(&H220F)
        Case "radic"    ' # SQUARE ROOT
          Html2Unicode = ChrW(&H221A)
        Case "sdot"    ' # DOT OPERATOR
          Html2Unicode = ChrW(&H22C5)
        Case "not"    ' # NOT SIGN
          Html2Unicode = ChrW(&HAC)
        Case "and"    ' # LOGICAL AND
          Html2Unicode = ChrW(&H2227)
        Case "or"    ' # LOGICAL OR
          Html2Unicode = ChrW(&H2228)
        Case "hArr"    ' # LEFT RIGHT DOUBLE ARROW
          Html2Unicode = ChrW(&H21D4)
        Case "lArr"    ' # LEFTWARDS DOUBLE ARROW
          Html2Unicode = ChrW(&H21D0)
        Case "uArr"    ' # UPWARDS DOUBLE ARROW
          Html2Unicode = ChrW(&H21D1)
        Case "rArr"    ' # RIGHTWARDS DOUBLE ARROW
          Html2Unicode = ChrW(&H21D2)
        Case "dArr"    ' # DOWNWARDS DOUBLE ARROW
          Html2Unicode = ChrW(&H21D3)
        Case "loz"    ' # LOZENGE
          Html2Unicode = ChrW(&H25CA)
        Case "lang"    ' # LEFT-POINTING ANGLE BRACKET
          Html2Unicode = ChrW(&H2329)
        Case "registersans"    ' # REGISTERED SIGN SANS SERIF
          Html2Unicode = ChrW(&HF8E8)
        Case "copyrightsans"    ' # COPYRIGHT SIGN SANS SERIF
          Html2Unicode = ChrW(&HF8E9)
        Case "trademarksans"    ' # TRADE MARK SIGN SANS SERIF
          Html2Unicode = ChrW(&HF8EA)
        Case "summation"    ' # N-ARY SUMMATION
          Html2Unicode = ChrW(&H2211)
        Case "parenlefttp"    ' # LEFT PAREN TOP
          Html2Unicode = ChrW(&HF8EB)
        Case "parenleftex"    ' # LEFT PAREN EXTENDER
          Html2Unicode = ChrW(&HF8EC)
        Case "parenleftbt"    ' # LEFT PAREN BOTTOM
          Html2Unicode = ChrW(&HF8ED)
        Case "bracketlefttp"    ' # LEFT SQUARE BRACKET TOP
          Html2Unicode = ChrW(&HF8EE)
        Case "bracketleftex"    ' # LEFT SQUARE BRACKET EXTENDER
          Html2Unicode = ChrW(&HF8EF)
        Case "bracketleftbt"    ' # LEFT SQUARE BRACKET BOTTOM
          Html2Unicode = ChrW(&HF8F0)
        Case "bracelefttp"    ' # LEFT CURLY BRACKET TOP
          Html2Unicode = ChrW(&HF8F1)
        Case "braceleftmd"    ' # LEFT CURLY BRACKET MID
          Html2Unicode = ChrW(&HF8F2)
        Case "braceleftbt"    ' # LEFT CURLY BRACKET BOTTOM
          Html2Unicode = ChrW(&HF8F3)
        Case "braceleftex"    ' # CURLY BRACKET EXTENDER
          Html2Unicode = ChrW(&HF8F4)
        Case "angleright"    ' # RIGHT-POINTING ANGLE BRACKET
          Html2Unicode = ChrW(&H232A)
        Case "integral"    ' # INTEGRAL
          Html2Unicode = ChrW(&H222B)
        Case "integraltp"    ' # TOP HALF INTEGRAL
          Html2Unicode = ChrW(&H2320)
        Case "integralex"    ' # INTEGRAL EXTENDER
          Html2Unicode = ChrW(&HF8F5)
        Case "integralbt"    ' # BOTTOM HALF INTEGRAL
          Html2Unicode = ChrW(&H2321)
        Case "parenrighttp"    ' # RIGHT PAREN TOP
          Html2Unicode = ChrW(&HF8F6)
        Case "parenrightex"    ' # RIGHT PAREN EXTENDER
          Html2Unicode = ChrW(&HF8F7)
        Case "parenrightbt"    ' # RIGHT PAREN BOTTOM
          Html2Unicode = ChrW(&HF8F8)
        Case "bracketrighttp"    ' # RIGHT SQUARE BRACKET TOP
          Html2Unicode = ChrW(&HF8F9)
        Case "bracketrightex"    ' # RIGHT SQUARE BRACKET EXTENDER
          Html2Unicode = ChrW(&HF8FA)
        Case "bracketrightbt"    ' # RIGHT SQUARE BRACKET BOTTOM
          Html2Unicode = ChrW(&HF8FB)
        Case "bracerighttp"    ' # RIGHT CURLY BRACKET TOP
          Html2Unicode = ChrW(&HF8FC)
        Case "bracerightmd"    ' # RIGHT CURLY BRACKET MID
          Html2Unicode = ChrW(&HF8FD)
        Case "bracerightbt"    ' # RIGHT CURLY BRACKET BOTTOM
          Html2Unicode = ChrW(&HF8FE)
    
    Case Else ' PUNT
        Html2Unicode = "&" & HtmlTag & ";"
    End Select

End Function

Function GetLine(SourceString As String, Delim As String) As String

    Dim pos As Long
    
    pos = InStr(1, SourceString, Delim)
    
    If pos = 0 Then
        GetLine = SourceString
        SourceString = ""
        Exit Function
    End If
    
    GetLine = Left(SourceString, pos - 1)
    SourceString = Mid(SourceString, pos + 1)

End Function

Sub FontInfoGoingOutOfScope(HtmlTag As String)
    
    If HtmlTag = "nochange" Then
        Exit Sub
    ElseIf HtmlTag = "p" Then
        Selection.TypeParagraph
        Exit Sub
    End If
                       
    Select Case GetLine(HtmlTag, ":")
    
        Case "bold"
            Selection.Font.Bold = False
        
        Case "underline"
            Selection.Font.Underline = CLng(HtmlTag)
        
        Case "italic"
            Selection.Font.Italic = False
        
        ' possibilities:
        ' font:face:face_name:color:num
        ' font:color:num:face:face_name
        ' font:face:face_name
        ' font:color:num
        Case "font"
            Dim key As String
            key = GetLine(HtmlTag, ":")
            If key = "face" Then
                    Selection.Font.Name = GetLine(HtmlTag, ":")
                    If HtmlTag <> "" Then
                        key = GetLine(HtmlTag, ":")
                        Selection.Font.ColorIndex = CLng(HtmlTag)
                    End If
            ElseIf key = "color" Then
                    Selection.Font.ColorIndex = CLng(GetLine(HtmlTag, ":"))
                    If HtmlTag <> "" Then
                        key = GetLine(HtmlTag, ":")
                        Selection.Font.Name = HtmlTag
                    End If
            End If
        
        Case "sub"
            Selection.Font.Subscript = False
            
        Case "sup"
            Selection.Font.Superscript = False
        
        Case "color"
            Selection.Font.ColorIndex = CLng(HtmlTag)
    
    End Select

End Sub


Function ParseHtmlTag(HtmlTag As String) As String
    
   
    'easy stuff first
    
   
    HtmlTag = LCase(HtmlTag)
    
    Select Case HtmlTag
    
    ' paragraph
    Case "p"
        Selection.TypeParagraph
        ParseHtmlTag = "p"
        Exit Function
    
    ' bold
    Case "b", "strong"
        If Selection.Font.Bold = True Then
            ParseHtmlTag = "nochange"
        Else
            ParseHtmlTag = "bold:False"
        End If
        Selection.Font.Bold = True
        Exit Function

    'underline
    Case "u"
        ParseHtmlTag = "underline:" & CStr(Selection.Font.Underline)
        Selection.Font.Underline = wdUnderlineSingle
        Exit Function

    'italic
    Case "i", "em"
        If Selection.Font.Italic = True Then
            ParseHtmlTag = "nochange"
        Else
            ParseHtmlTag = "italic:False"
        End If
        Selection.Font.Italic = True
        Exit Function

    ' superscript
    Case "sup"
        If Selection.Font.Superscript = True Then
            ParseHtmlTag = "nochange"
        Else
            ParseHtmlTag = "sup:False"
        End If
        Selection.Font.Superscript = True
        Exit Function
    
    ' subscript
    Case "sub"
        If Selection.Font.Subscript = True Then
            ParseHtmlTag = "nochange"
        Else
            ParseHtmlTag = "sub:False"
        End If
        Selection.Font.Subscript = True
        Exit Function

    End Select
    
    ' ok, the hard stuff then
    
    ' font
    If Left(HtmlTag, 4) = "font" Then
        ParseHtmlTag = "font:" & ParseFontHtmlTag(Mid(HtmlTag, 6))
        Exit Function
    End If
    
    Dim pos As Long
    
    ' color
    ' the tag must look like the following:
    ' span style="color:blue"
    If Left(HtmlTag, 4) = "span" Then
        ' we only handle color for now
        pos = InStr(1, HtmlTag, "color:")
        If pos = 0 Then
            ParseHtmlTag = "nochange"
            Exit Function
        End If
        ' get past the colon
        pos = InStr(1, HtmlTag, ":")
        HtmlTag = Mid(HtmlTag, pos + 1)
        ' get the color
        ParseHtmlTag = "color:" & CStr(Selection.Font.ColorIndex)
        Selection.Font.ColorIndex = ColorString2Long(LCase(GetLine(HtmlTag, """")))
        Exit Function
  End If

   
    Debug.Print "*** UNKNOWN STYLE FORMAT: " & HtmlTag

End Function

Private Function ParseFontHtmlTag(Tag As String) As String
  
    Dim key As String
    Dim value As String
    
    Dim pos As Integer
    
    ' get the key
    key = GetLine(Tag, "=")
    
    ' get the value
    If Left(Tag, 1) = """" Then     ' the value is wrapped in quotes
        Tag = Mid(Tag, 2)
        pos = InStr(1, Tag, """")
        value = Left(Tag, pos - 1)
        Tag = Mid(Tag, pos + 2)
    Else                            ' not wrapped in quotes -- naughty naughty, but we turn a blind eye...
        pos = InStr(1, Tag, " ")
        If pos > 0 Then
            value = Left(Tag, pos - 1)
            Tag = Mid(Tag, pos + 1)
        Else
            value = Tag
            Tag = ""
        End If
    End If

    Tag = LTrim(Tag)
    Select Case key ' now find out what our key was...
    
        Case "face"
            ParseFontHtmlTag = "face:" & Selection.Font.Name
            Selection.Font.Name = value
        
        Case "color"
            ParseFontHtmlTag = "color:" & CStr(Selection.Font.ColorIndex)
            Selection.Font.ColorIndex = ColorString2Long(LCase(value))
            
    End Select
    

    If Tag = "" Then
        Exit Function
    End If
    
    ' Say it with me -- recursion is our friend!
    ParseFontHtmlTag = ParseFontHtmlTag & ":" & ParseFontHtmlTag(Tag)

End Function

'================================================
'  Concat                                       +
'================================================
Public Sub Concat(Dest As String, Source As String)
    Dim l As Long
    l = Len(Source)
    If (ccOffset + l) >= Len(Dest) Then
        If l > ccIncrement Then
          Dest = Dest & Space$(l)
        Else
          Dest = Dest & Space$(ccIncrement)
        End If
    End If
    Mid$(Dest, ccOffset + 1, l) = Source
    ccOffset = ccOffset + l
End Sub

'=====================================================
' Replace all occurrances of from_str with to_str.   +
' Usage: Ouput = ReplaceText( "ABC", "A", "B" )      +
'        Result: Output = "BBC"                      +
'=====================================================
Public Function ReplaceText(ByVal txt As String, ByVal _
    from_str As String, ByVal to_str As String) As String
    
    Dim result As String
    Dim from_len As Integer
    Dim pos As Integer

    from_len = Len(from_str)
    Do While Len(txt) > 0
        ' Find from_str.
        pos = InStr(txt, from_str)
        If pos = 0 Then
            ' No more occurrences.
            result = result & txt
            txt = ""
        Else
            ' Make the replacement.
            result = result & Left$(txt, pos - 1) & to_str
            txt = Mid$(txt, pos + from_len)
        End If
    Loop

    ReplaceText = result
End Function

' ========================================================
' ||                                                    ||
' || WORD 97 SPECIFIC                                   ||
' ||                                                    ||
' ========================================================

Function ColorLong2String(Color As Long) As String

Select Case Color

    Case wdAuto
        ColorLong2String = "#000000"
    Case wdBlack
        ColorLong2String = "#000000"
    Case wdBlue
        ColorLong2String = "#0000ff"
    Case wdBrightGreen
        ColorLong2String = "#66FF66"
    Case wdDarkBlue
        ColorLong2String = "#00008b"
    Case wdDarkRed
        ColorLong2String = "#8b0000"
    Case wdDarkYellow
        ColorLong2String = "darkyellow"
    Case wdGray25
        ColorLong2String = "#CCCCCC"
    Case wdGray50
        ColorLong2String = "#999999"
    Case wdGreen
        ColorLong2String = "#008000"
    Case wdNoHighlight
        ColorLong2String = "#000000"
    Case wdPink
        ColorLong2String = "#ffc0cd"
    Case wdRed
        ColorLong2String = "#ff0000"
    Case wdTeal
        ColorLong2String = "#008080"
    Case wdTurquoise
        ColorLong2String = "#40e0d0"
    Case wdViolet
        ColorLong2String = "#ee82ee"
    Case wdWhite
        ColorLong2String = "#ffffff"
    Case wdYellow
        ColorLong2String = "#ffff00"
    Case Else
        ColorLong2String = "#000000"

End Select

End Function

Function ColorString2Long(Color As String) As Long

Select Case LCase(Trim(Color))

    Case "white", "#ffffff"
        ColorString2Long = wdWhite
    Case "black", "#000000"
        ColorString2Long = wdBlack
    Case "blue", "#0000ff"
        ColorString2Long = wdBlue
    Case "#66ff66", "brightgreen"
        ColorString2Long = wdBrightGreen
    Case "#00008b", "darkblue"
        ColorString2Long = wdDarkBlue
    Case "#8b0000", "darkred"
        ColorString2Long = wdDarkRed
    Case "darkyellow"
        ColorString2Long = wdDarkYellow
    Case "#cccccc", "lightgray"
        ColorString2Long = wdGray25
    Case "#999999", "gray", "darkgray"
        ColorString2Long = wdGray50
    Case "#008000", "green"
        ColorString2Long = wdGreen
    Case "#ffc0cd", "pink"
        ColorString2Long = wdPink
    Case "#ff0000", "red"
        ColorString2Long = wdRed
    Case "#008080", "teal"
        ColorString2Long = wdTeal
    Case "#40e0d0", "turquoise"
        ColorString2Long = wdTurquoise
    Case "#ee82ee", "violet"
        ColorString2Long = wdViolet
    Case "#ffff00", "yellow"
        ColorString2Long = wdYellow
    Case Else
        Debug.Print "*** Unknown color code: " & Color
        ColorString2Long = wdAuto
End Select

End Function