Sub CopyTextSimple()
' Paul Beverley - Version 19.07.25
' Creates a text-only copy, with some features preserved

doItalic = True
doBold = True
doSub = True
doSuper = True
doListNumbers = True

myColour = wdGray25

myDelay = 5
myDelay2 = 1

myComments = ""

Set rngOld = ActiveDocument.Content
myLanguage = rngOld.Characters(1).LanguageID
Set newDoc = Documents.Add
newDoc.Content.FormattedText = rngOld.FormattedText
For i = 1 To 200 * myDelay: DoEvents: Next i

If doListNumbers = True Then newDoc.ConvertNumbersToText
Set rng = newDoc.Content
rng.Revisions.AcceptAll
rng.Fields.Unlink
rng.LanguageID = myLanguage
If numberCmnts > 0 Then newDoc.DeleteAllComments
For i = 1 To 200 * myDelay: DoEvents: Next i

wds1 = rng.Words.Count
rng.Font.Hidden = False
wds2 = rng.Words.Count
If wds2 <> wds1 Then
  WordBasic.EditUndo
  myResponse = MsgBox("Original contains " & wds2 - wds1 & _
       " words of hidden text. Include it?", _
       vbQuestion + vbYesNoCancel, "CopyText")
  If myResponse = vbCancel Then Exit Sub
  If myResponse = vbYes Then
    newDoc.ActiveWindow.View.ShowHiddenText = True
    oldColour = Options.DefaultHighlightColorIndex
    Options.DefaultHighlightColorIndex = myColour
    Set rng = newDoc.Content
    With rng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = ""
      .Font.Hidden = True
      .Wrap = wdFindContinue
      .Replacement.Font.Hidden = False
      .Replacement.Highlight = True
      .Replacement.Text = ""
      .Execute Replace:=wdReplaceAll
      For kk = 1 To myDelay2: DoEvents: Next kk
    End With
    newDoc.ActiveWindow.View.ShowHiddenText = False
  End If
End If

numNotes = newDoc.Endnotes.Count
If numNotes > 0 Then
  myComments = myComments & "| endnotes = yes (" _
       & Trim(Str(numNotes)) & ")" & vbCr
  Set rng = newDoc.Content
  rng.Collapse wdCollapseEnd
  rng.InsertAfter Text:=vbCr & "Endnotes:" & vbCr & vbCr
  rng.Collapse wdCollapseEnd
  rng.FormattedText = _
       newDoc.StoryRanges(wdEndnotesStory).FormattedText
  ' Delete all notes
  For j = numNotes To 1 Step -1
    newDoc.Endnotes(j).Delete
    DoEvents
  Next j
End If

numNotes = newDoc.Footnotes.Count
If numNotes > 0 Then
  myComments = myComments & "| footnotes = yes (" _
       & Trim(Str(numNotes)) & ")" & vbCr
  Set rng = newDoc.Content
  rng.Collapse wdCollapseEnd
  rng.InsertAfter Text:=vbCr & "Footnotes:" & vbCr & vbCr
  rng.Collapse wdCollapseEnd
  rng.FormattedText = _
       newDoc.StoryRanges(wdFootnotesStory).FormattedText
  ' Delete all notes
  For j = numNotes To 1 Step -1
    newDoc.Footnotes(j).Delete
    DoEvents
  Next j
End If

' copy all the textboxes to the end of the text
shCount = newDoc.Shapes.Count
tbCount = 0
If shCount > 0 Then
  Selection.EndKey Unit:=wdStory
  Selection.TypeText vbCr & "Textboxes:" & vbCr & vbCr
  For j = 1 To shCount
    Set shp = newDoc.Shapes(j)
    If shp.Type <> 24 And shp.Type <> 3 Then
      If shp.TextFrame.HasText Then
        Set rng = shp.TextFrame.TextRange
        If Len(rng.Text) > 1 Then
          tbCount = tbCount + 1
          Selection.FormattedText = rng.FormattedText
          Selection.EndKey Unit:=wdStory
        End If
      End If
    End If
    For kk = 1 To myDelay2: DoEvents: Next kk
  Next
  If tbCount > 0 Then myComments = myComments & _
       "| textboxes = yes (" & Trim(Str(tbCount)) _
       & ")" & vbCr
End If

' Add a newline for safety
Selection.TypeText vbCr
Selection.HomeKey Unit:=wdStory
If myComments > "" Then Selection.TypeText myComments & vbCr

' Watch out for hard spaces and spaced dots for ellipses
Set rng = newDoc.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^s"
  .Wrap = wdFindContinue
  .Replacement.Text = " "
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ". . ."
  .Wrap = wdFindContinue
  .Replacement.Text = "…"
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Highlight = True
  .Wrap = wdFindContinue
  .Replacement.Text = "vkvk^&kvkv"
  .MatchCase = True
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With

If doItalic = True Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Italic = True
    .Wrap = wdFindContinue
    .Replacement.Text = "zczc^&czcz"
    .MatchCase = True
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
End If

If doBold = True Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Bold = True
    .Wrap = wdFindContinue
    .Replacement.Text = "jqjq^&qjqj"
    .MatchCase = True
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
End If

If doSub = True Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Subscript = True
    .Wrap = wdFindContinue
    .Replacement.Text = "xbxb^&bxbx"
    .MatchCase = True
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
End If

If doSuper = True Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Superscript = True
    .Wrap = wdFindContinue
    .MatchCase = True
    .Replacement.Text = "xsxs^&sxsx"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
End If

' Copy pure text after the end of the formatted text
allText = newDoc.Content.Text
newDoc.Content.Text = vbCr
newDoc.Content.Style = newDoc.Styles(wdStyleNormal)
newDoc.Content.Text = allText

Set rng = newDoc.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[^12^14]"
  .Wrap = wdFindContinue
  .Replacement.Text = "^p"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With

If doSuper = True Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "xsxs(*)sxsx"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Superscript = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "XSXS(*)SXSX"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Superscript = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  For kk = 1 To myDelay2: DoEvents: Next kk
End If

If doSub = True Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "xbxb(*)bxbx"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Subscript = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  For kk = 1 To myDelay2: DoEvents: Next kk
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "XBXB(*)BXBX"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Subscript = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
End If

If doBold = True Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "jqjq(*)qjqj"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Bold = True
    .MatchCase = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "JQJQ(*)QJQJ"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Bold = True
    .MatchCase = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
End If

If doItalic = True Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "zczc(*)czcz"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Italic = True
    .MatchCase = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "ZCZC(*)CZCZ"
    .Wrap = wdFindContinue
    .Replacement.Text = "\1"
    .Replacement.Font.Italic = True
    .MatchCase = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  For kk = 1 To myDelay2: DoEvents: Next kk
End If

' Restore Highlight
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "vkvk(*)kvkv"
  .Wrap = wdFindContinue
  .Replacement.Text = "\1"
  .Replacement.Highlight = True
  .MatchCase = True
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "VKVK(*)KVKV"
  .Wrap = wdFindContinue
  .Replacement.Text = "\1"
  .Replacement.Highlight = True
  .MatchCase = True
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With
Options.DefaultHighlightColorIndex = oldColour

' Tidy up picture markers
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "^1"
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[^13]{3,}"
  .Wrap = wdFindContinue
  .Replacement.Text = "^p^p"
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[vkjzcqxbsVKJZCQXBS]{4,}"
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  For kk = 1 To myDelay2: DoEvents: Next kk
End With

If tbCount = 0 Then
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Textboxes:"
    .Wrap = wdFindContinue
    .Replacement.Text = ""
    .MatchCase = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    For kk = 1 To myDelay2: DoEvents: Next kk
  End With
End If
Beep
End Sub