Sub Extract_AutoTextList_ScreenTip()
  Dim strFieldData() As String
  Dim oDoc As Word.Document
  Dim strFileName As String
  Dim oDocReport As Word.Document
  Dim oTbl As Word.Table
  Dim oRow As Word.Row
  Dim lngIndex As Long
  strFieldData() = fcnFieldData
  'If CountATLFields = 0 Then
    'MsgBox ("There are no AutoTextLink fields in this document."), , "Field Count"
    'Exit Sub
  'End If
  Set oDoc = ActiveDocument
  strFileName = oDoc.FullName
  'Create a new document for the extract
  Set oDocReport = Documents.Add
  'Insert a 3-column table for the extract
  Application.ScreenUpdating = False
  With oDocReport
    .Content = ""
    'Set orientation to landscape
    .PageSetup.Orientation = wdOrientLandscape
    Set oTbl = .Tables.Add(Range:=Selection.Range, _
       NumRows:=UBound(strFieldData, 2) + 3, NumColumns:=3)
    End With
    With oTbl
      For Each oRow In oTbl.Range.Rows
        oRow.Cells(1).Width = InchesToPoints(0.7)
        oRow.Cells(2).Width = InchesToPoints(2)
        oRow.Cells(3).Width = InchesToPoints(3)
      Next
      With .Rows(1)
        .Cells.Merge
        .Cells(1).Range.Text = "File name: " & strFileName & vbCr & _
        "Created by: " & Application.UserName & vbCr & _
        "Creation date: " & Format(Date, "MMMM d, yyyy")
        .Range.Font.Bold = True
        .Shading.BackgroundPatternColor = wdColorGray125
      End With
      With .Rows(2)
        .Range.Font.Bold = True
        .Cells(1).Range.Text = "Page #"
        .Cells(2).Range.Text = "Display Text"
        .Cells(3).Range.Text = "Screen Tip"
      End With
      For lngIndex = 1 To 6
        With .Borders(lngIndex)
          .LineStyle = wdLineStyleSingle
          .LineWidth = wdLineWidth050pt
          .Color = wdColorAutomatic
        End With
      Next
      With Options
        .DefaultBorderLineStyle = wdLineStyleSingle
        .DefaultBorderLineWidth = wdLineWidth050pt
        .DefaultBorderColor = wdColorAutomatic
      End With
   End With
   For lngIndex = 0 To UBound(strFieldData, 2)
     With oTbl.Rows(lngIndex + 3)
       .Cells(1).Range.Text = strFieldData(0, lngIndex)
       .Cells(2).Range.Text = strFieldData(1, lngIndex)
       .Cells(3).Range.Text = strFieldData(2, lngIndex)
     End With
   Next lngIndex
   Application.ScreenUpdating = True
End Sub

Function fcnFieldData() As String()
Dim lngJunk As Long
Dim oFld As Word.Field
Dim rngStory As Word.Range
Dim arrTemp() As String
Dim arrParts() As String
Dim lngCOunt As Long
  lngCOunt = 0
  'Word missing first Header/Footer bug workaround
  lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  'Iterate through all story types in the current document
  For Each rngStory In ActiveDocument.StoryRanges
    'Iterate through all linked stories
    Do
      For Each oFld In rngStory.Fields
        If oFld.Type = wdFieldAutoTextList Then
          ReDim Preserve arrTemp(2, lngCOunt)
          arrTemp(0, lngCOunt) = oFld.Code.Information(wdActiveEndPageNumber)
          arrTemp(1, lngCOunt) = oFld.Result
          arrParts = Split(oFld.Code, """")
          arrTemp(2, lngCOunt) = arrParts(1)
          lngCOunt = lngCOunt + 1
        End If
      Next
    'Get next linked story (if any)
    Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
  Next
  fcnFieldData = arrTemp
End Function