Sub MultiFileText()
' Paul Beverley - Version 16.11.23
' Collects text plus simple formatting from multiple files

spaceEquations = True
listOff = True
addFilename = True
convertMathsItems = True
remindAboutCancel = True

myScreenOff = True

CR2 = vbCr & vbCr
Dim allMyFiles2(200) As String
Set rng = ActiveDocument.Content
myExtent = 250
myDelay = 10

' First find if this is a Mac or a PC!
myFolder = ActiveDocument.Path
myDelimiter = Application.PathSeparator
If myDelimiter = "/" Then
  InAMac = True
Else
  InAMac = False
End If

If rng.End - rng.Start > myExtent Then rng.End = rng.Start + myExtent
If InStr(LCase(rng.Text), ".doc") = 0 _
     And InStr(LCase(rng.Text), ".rtf") = 0 _
     And InStr(LCase(rng.Text), ".pdf") = 0 Then
' If not a file list then navigate to the required folder
  If remindAboutCancel = True Then myResponse = _
       MsgBox("Navigate to the required folder; then press 'Cancel'" _
      , , "Multifile Text Collection")
  docCount = Documents.Count
  Dialogs(wdDialogFileOpen).Show
  If Documents.Count > docCount Then ActiveDocument.Close
  dirPath = CurDir()
  ChDir dirPath
' Read the names of all the files in this directory
  myFile = Dir(CurDir() & myDelimiter)
  Documents.Add
  numFiles = 0
  Do While myFile <> ""
    If InStr(LCase(myFile), ".doc") > 0 Or _
         InStr(LCase(myFile), ".rtf") > 0 Or _
         InStr(LCase(myFile), ".pdf") > 0 Then
      Selection.TypeText myFile & vbCr
      numFiles = numFiles + 1
    End If
    myFile = Dir()
  Loop

' Now sort the file list (only actually needed for Macs)
  Selection.WholeStory
  Selection.Sort SortOrder:=wdSortOrderAscending, _
       SortFieldType:=wdSortFieldAlphanumeric
  Selection.EndKey Unit:=wdStory
  Selection.TypeParagraph
  Selection.HomeKey Unit:=wdStory
  Selection.TypeText dirPath
' Go back until you hit myDelimiter
  Selection.MoveStartUntil cset:=myDelimiter, Count:=wdBackward
  dirName = Selection
  Selection.HomeKey Unit:=wdStory

  myResponse = MsgBox("Collect unformatted text from ALL the files in" & _
       " directory: " & dirName & "?", vbQuestion + vbYesNoCancel, _
       "Multifile Text Collection")
  If myResponse <> vbYes Then Exit Sub
Else
  myResponse = MsgBox("Collect unformatted text from the files listed here?", _
       vbQuestion + vbYesNoCancel, "Multifile Text Collection")
  If myResponse <> vbYes Then Exit Sub
End If
If InAMac = False Then
  ActiveDocument.ActiveWindow.WindowState = wdWindowStateNormal
  Application.Move Left:=20, Top:=300
  Application.Resize Width:=1000, Height:=200
End If

' Pick up the folder name and the filenames from the file list
numFiles = 0

If myScreenOff = True Then
  Application.ScreenUpdating = False
  On Error GoTo ReportIt
End If

myFolder = ""
For Each myPara In ActiveDocument.Paragraphs
  myPara.Range.Select
  Selection.MoveEnd , -1
  lineText = Selection
  If myFolder = "" Then
    myFolder = lineText
    Selection.Collapse wdCollapseEnd
    Selection.MoveStartUntil cset:=myDelimiter, Count:=wdBackward
    Selection.MoveStart , -1
    myDelimiter = Left(Selection, 1)
  Else
    thisFile = lineText
    If Len(thisFile) > 2 Then
      If Left(thisFile, 1) <> "=" Then
        numFiles = numFiles + 1
        allMyFiles2(numFiles) = thisFile
      End If
    End If
  End If
Next myPara
Selection.HomeKey Unit:=wdStory

Set alltextDoc = Documents.Add
Set alltextRng = ActiveDocument.Content
Selection.HomeKey Unit:=wdStory
gotLanguage = False

For i = 1 To numFiles
' Get the folder name, and then the text for the files in the list
  StatusBar = allMyFiles2(i)
  thisFile = myFolder & myDelimiter & allMyFiles2(i)
  Set myDoc = Application.Documents.Open(fileName:=thisFile)

  If gotLanguage = False Then
    Selection.MoveEnd , 1
    myLanguage = Selection.Range.LanguageID
    gotLanguage = True
  End If
  numEqns = ActiveDocument.OMaths.Count
  If numEqns > 0 And spaceEquations = True Then
    For Each myMath In ActiveDocument.OMaths
      myMath.Range.InsertBefore Text:=" "
      DoEvents
      numEqns = numEqns - 1
    Next myMath
  End If
  DoEvents
  myDoc.Revisions.AcceptAll
  myDoc.TrackRevisions = False
  If listOff = True Then myDoc.ConvertNumbersToText
  If ActiveDocument.Endnotes.Count > 0 Then
    Set thisDocRange = myDoc.Content
    thisDocRange.Collapse wdCollapseEnd
    thisDocRange.FormattedText = _
         myDoc.StoryRanges(wdEndnotesStory).FormattedText
  End If
  If ActiveDocument.Footnotes.Count > 0 Then
    Set thisDocRange = myDoc.Content
    thisDocRange.Collapse wdCollapseEnd
    thisDocRange.FormattedText = _
         myDoc.StoryRanges(wdFootnotesStory).FormattedText
  End If

  ' copy all the textboxes to the end of the text
  shCount = myDoc.Shapes.Count
  If shCount > 0 Then
    Selection.EndKey Unit:=wdStory
    Selection.TypeText vbCr & vbCr
    For j = 1 To shCount
      Set shp = ActiveDocument.Shapes(j)
      If shp.Type <> 24 And shp.Type <> 3 Then
        If shp.TextFrame.HasText Then
          Set rng = shp.TextFrame.TextRange
          Selection.FormattedText = rng.FormattedText
          Selection.EndKey Unit:=wdStory
        End If
      End If
    Next
  End If

  StatusBar = allMyFiles2(i)
  Selection.HomeKey Unit:=wdStory
  DoEvents
  If addFilename = True Then Selection.TypeText CR2 & "[[[[ " & _
       allMyFiles2(i) & " ]]]]]" & CR2
  If convertMathsItems = True Then
    numMaths = ActiveDocument.OMaths.Count
    If numMaths > 0 Then
      For Each myMath In ActiveDocument.OMaths
        myMath.Range.Select
        eqText = Replace(Selection.Text, vbCr, " ")
        Selection.MoveStart , -1
        Selection.Delete
        startHere = Selection.Start
        Selection.TypeText eqText
        Selection.Start = startHere
      Next myMath
    End If
  End If
  
  myDoc.Fields.Unlink
  ' Accept all track changes
  myDoc.Range.Revisions.AcceptAll
  myDoc.TrackRevisions = False
  Set rng = ActiveDocument.Content
  DoEvents
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Italic = True
    .Wrap = wdFindContinue
    .MatchWildcards = False
    .MatchCase = True
    .Replacement.Text = "=i=i=^&=j=j="
    .Replacement.Highlight = True
    .Execute Replace:=wdReplaceAll
  DoEvents
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Bold = True
    .Replacement.Text = "=b=b=^&=c=c="
    .Replacement.Highlight = True
    .Execute Replace:=wdReplaceAll
  DoEvents
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Superscript = True
    .Replacement.Text = "=u=u=^&=v=v="
    .Execute Replace:=wdReplaceAll
  DoEvents
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Subscript = True
    .Replacement.Text = "=s=s=^&=t=t="
    .Execute Replace:=wdReplaceAll
  DoEvents
  End With

  Set rng = ActiveDocument.Content
  alltextRng.End = alltextDoc.Range.End
  alltextRng.Start = alltextDoc.Range.End
  alltextRng.Text = rng.Text
  For j = 1 To myDelay
    DoEvents
  Next j
  myDoc.Close SaveChanges:=wdDoNotSaveChanges
Next i

Set rng = alltextDoc.Content
rng.LanguageID = myLanguage
rng.NoProofing = False

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "=s=s=(*)=t=t="
  .MatchWildcards = True
  .Replacement.Text = "\1"
  .Replacement.Font.Subscript = True
  .Execute Replace:=wdReplaceAll
  For j = 1 To myDelay
    DoEvents
  Next j
  
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "=u=u=(*)=v=v="
  .Replacement.Text = "=\1"
  .Replacement.Font.Superscript = True
  .Font.Underline = True
  .Execute Replace:=wdReplaceAll
  For j = 1 To myDelay
    DoEvents
  Next j

  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "=b=b=(*)=c=c="
  .Replacement.Text = "\1"
  .Replacement.Font.Bold = True
  .Execute Replace:=wdReplaceAll
  For j = 1 To myDelay
    DoEvents
  Next j

  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "=i=i=(*)=j=j="
  .Replacement.Text = "\1"
  .Replacement.Font.Italic = True
  .Execute Replace:=wdReplaceAll
  For j = 1 To myDelay
    DoEvents
  Next j

' Remove optional hyphens
  .ClearFormatting
  .Replacement.ClearFormatting
  .MatchWildcards = False
  .Replacement.Text = ""
  .Text = ChrW(172)
  .Execute Replace:=wdReplaceAll
  For j = 1 To myDelay
    DoEvents
  Next j
End With

Set rng = ActiveDocument.Content
totChars = rng.End
' Add one '[' for each file, to check they are all there
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[[[[ "
  .Wrap = wdFindContinue
  .MatchWildcards = False
  .MatchWholeWord = False
  .Replacement.Text = "[[[[[ "
  .Execute Replace:=wdReplaceAll
  For j = 1 To myDelay
    DoEvents
  Next j
End With
ActiveDocument.Paragraphs(3).Range.Bold = True
Set rng = ActiveDocument.Content
totCharsNow = rng.End
If InAPC = True Then
  ActiveDocument.ActiveWindow.WindowState = wdWindowStateNormal
  Application.Resize Width:=1000, Height:=500
End If
Beep
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[[[[["
  .Wrap = wdFindContinue
  .MatchWildcards = False
  .MatchWholeWord = False
  .Replacement.Text = ""
  .Execute
End With
Selection.Collapse wdCollapseEnd

Application.ScreenUpdating = True

If totCharsNow - totChars <> numFiles Then
  Beep
  myTime = Timer
  Do
  Loop Until Timer > myTime + 0.2
  Beep
  MsgBox "Warning: All files might not have been included."
End If
Exit Sub

ReportIt:
Application.Visible = True
On Error GoTo 0
Resume
End Sub