Extract highlighted words

extractHighlighted.vb

Sub extractHighlighted()

  Dim objUndo As UndoRecord
  Set objUndo = Application.UndoRecord
  objUndo.StartCustomRecord ("Extract Highlighted Text")

  Selection.ClearFormatting
  Selection.HomeKey wdStory, wdMove
  
  Selection.Find.ClearFormatting
  Selection.Find.Highlight = True

  'Dim items As New ArrayList
  'Dim items As Object
  'Set items = CreateObject("System.Collections.ArrayList")
  Dim items As New Collection

  Dim found As Boolean
  found = True

  Dim a As Integer

  a = 0
  Do While found 'And a < 50
    found = Selection.Find.Execute
    If found Then
      items.Add Selection.Text
      ' Ensure termination, i.e. that we don't select the same text again.
      ' This happens sometimes for unknown reasons in Word 365.
      Selection.Collapse wdCollapseEnd
    End If
    a = a + 1
  Loop

  ActiveDocument.Range.InsertParagraphAfter
 
  For Each Item In items

    ' Put each item at the end of the document
    Dim oRng As Range
    Set oRng = ActiveDocument.Range
    oRng.Collapse wdCollapseEnd

    Dim Box As Shape
    Set Box = ActiveDocument.Shapes.AddTextbox( _
    Orientation:=msoTextOrientationHorizontal, Left:=0, Top:=0, Width:=100, Height:=100, Anchor:=oRng)

    Box.TextFrame.TextRange.Text = Item & vbNewLine & vbNewLine & "File name: " & ActiveDocument.Name

    ' The following line makes boxes not behave like images
    Box.WrapFormat.Type = wdWrapInline
  Next Item

  objUndo.EndCustomRecord

End Sub