Sub ForumTextFormat()
' Paul Beverley - Version 21.11.21
' Converts text from Word to Forum and vice versa

' Are there any existing format codes?
Set rng = ActiveDocument.Range
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
' Anything inside [], starting with /
  .Text = "\[/*\]"
  .Replacement.Text = ""
  .MatchWildcards = True
  .Execute
End With

If rng.Find.Found = True Then
' If so, restore Word formatting and remove them
  Set rng = ActiveDocument.Content
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[b\](*)\[/b\]"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Bold = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[i\](*)\[/i\]"
    .Replacement.Text = "\1"
    .Replacement.Font.Italic = True
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[u\](*)\[/u\]"
    .Replacement.Text = "\1"
    .Replacement.Font.Underline = True
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[sub\](*)\[/sub\]"
    .Replacement.Text = "\1"
    .Replacement.Font.Subscript = True
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[sup\](*)\[/sup\]"
    .Replacement.Text = "\1"
    .Replacement.Font.Superscript = True
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[s\](*)\[/s\]"
    .Replacement.Font.StrikeThrough = True
    .Replacement.Text = "\1"
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[color=#FF0000\](*)\[/color\]"
    .Replacement.Font.Color = wdColorRed
    .Replacement.Text = "\1"
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[color=#0000CC\](*)\[/color\]"
    .Replacement.Font.Color = wdColorBlue
    .Replacement.Text = "\1"
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[code]     [/code]"
    .Replacement.Text = "^t"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "\[code\](*)\[/code\]"
    .Replacement.Style = "HTML Sample"
    .Replacement.Text = "\1"
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<"
    .Replacement.Text = "<"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "&gt;"
    .Replacement.Text = ">"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
  End With
Else
' Otherwise ADD the forum commands
  Set rng = ActiveDocument.Content
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Bold = True
    .Replacement.Text = "[b]^&[/b]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Italic = True
    .Replacement.Text = "[i]^&[/i]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Subscript = True
    .Replacement.Text = "[sub]^&[/sub]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Superscript = True
    .Replacement.Text = "[sup]^&[/sup]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.StrikeThrough = True
    .Replacement.Text = "[s]^&[/s]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Underline = True
    .Replacement.Text = "[u]^&[/u]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Style = "HTML Sample"
    .Replacement.Text = "[code]^&[/code]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Color = wdColorBlue
    .Replacement.Text = "[color=#0000CC]^&[/color]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Color = wdColorRed
    .Replacement.Text = "[color=#FF0000]^&[/color]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
  
  normalFont = ActiveDocument.Styles(wdStyleNormal).Font.Name
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "'"
    .Font.Name = normalFont
    .Replacement.Text = "'"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = """"
    .Font.Name = normalFont
    .Replacement.Text = """"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = " - "
    .Replacement.Text = " ^= "
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ChrW(8216) & "quote" & ChrW(8217)
    .Replacement.Text = "^39quote^39"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^t"
    .Replacement.Text = "[code]     [/code]"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "<"
    .Replacement.Text = "&lt;"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ">"
    .Replacement.Text = "&gt;"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "&lt;div"
    .Replacement.Text = "<div"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "&lt;/div&gt;"
    .Replacement.Text = "</div>"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

  Options.AutoFormatAsYouTypeReplaceQuotes = False
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "'&gt;"
    .Replacement.Text = "'>"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
  End With
  Options.AutoFormatAsYouTypeReplaceQuotes = True
  Set rng = ActiveDocument.Content
  rng.Copy
End If
End Sub