Sub Extract_AutoTextList_ScreenTip()
 Dim CurrChar As String
 Dim DisplayTxt As String
Dim ScreenTipTxt As String
 Dim fcDisplay As Object
 Dim X As Long
 
 Set fcDisplay = ActiveWindow.View
 Application.ScreenUpdating = False
 Dim ExtractTxt As String
 
 Dim i As Integer
Dim lngJunk As Long
Dim fldItem As Word.Field
Dim fld As Field
Dim rngStory As Word.Range
'Dim CountCRStylesApplied As Long
'Dim ViewType As String
'Dim StyleExists As Boolean
'Dim alerts
Dim oDoc As Document, oNewDoc As Document
Dim oTable As Table, r As Range
Dim oRow As Row, Cancel As Integer
Dim n As Long
Dim FileName As String
Dim CountATLFields As Long
Dim fldItemIND As Integer
'Calls the function 'CountATLFields'
CountATLFields = Count_Auto_Text_List_Fields
If CountATLFields = 0 Then
MsgBox ("There are no AutoTextLink fields in this document."), , "Field Count"
Exit Sub
End If
Set oDoc = ActiveDocument
FileName = oDoc.FullName
  
'Create a new document for the extract
Set oNewDoc = Documents.Add
'Insert a 3-column table for the extract
With oNewDoc
.Content = ""
'sets orientation to landscape
.PageSetup.Orientation = wdOrientLandscape
Set oTable = .Tables.Add _
(Range:=Selection.Range, _
NumRows:=CountATLFields + 2, _
NumColumns:=3)
End With
 
 With oTable.Rows(2)
.Range.Font.Bold = True
.Cells(1).Range.Text = "Page #"
.Cells(2).Range.Text = "Display Text"
.Cells(3).Range.Text = "Screen Tip"
'Set table column widths
Set oTable = ActiveDocument.Tables(1)
With oTable
For Each oRow In oTable.Range.Rows
oRow.Cells(1).Width = InchesToPoints(0.7)
oRow.Cells(2).Width = InchesToPoints(2)
oRow.Cells(3).Width = InchesToPoints(3)
Next
End With
'Format the table
oTable.Select
  With Selection.Tables(1)
        With .Borders(wdBorderLeft)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        With .Borders(wdBorderRight)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        With .Borders(wdBorderTop)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        With .Borders(wdBorderBottom)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        With .Borders(wdBorderHorizontal)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        With .Borders(wdBorderVertical)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth050pt
            .Color = wdColorAutomatic
        End With
        .Borders(wdBorderDiagonalDown).LineStyle = wdLineStyleNone
        .Borders(wdBorderDiagonalUp).LineStyle = wdLineStyleNone
        .Borders.Shadow = False
    End With
    With Options
        .DefaultBorderLineStyle = wdLineStyleSingle
        .DefaultBorderLineWidth = wdLineWidth050pt
        .DefaultBorderColor = wdColorAutomatic
    End With
   
End With
     
 With oTable.Rows(1) 'Merge and write filename to first row
.Select
Selection.Cells.Merge
.Cells(1).Range.Text = "File name: " & FileName & vbCr & _
"Created by: " & Application.UserName & vbCr & _
"Creation date: " & Format(Date, "MMMM d, yyyy")
.Range.Font.Bold = True
.Shading.BackgroundPatternColor = wdColorGray125
End With
Application.ScreenUpdating = False
 
'Get Display text
n = 0
   lngJunk = oDoc.Sections(1).Headers(1).Range.StoryType
   'Iterate through all story types in the current document
   For Each rngStory In oDoc.StoryRanges
       'Iterate through all linked stories
       Do
           'Find only the AutoTextList fields
           fcDisplay.ShowFieldCodes = False
           fldItemIND = 0
            For Each fldItem In rngStory.Fields
            If fldItem.Type = wdFieldAutoTextList Then
            fldItemIND = 1
              n = n + 1
            'fldItem.Select
            DisplayTxt = fldItem.Result 'Selection.Text
            
             With oTable.Rows(n + 2)
    .Cells(2).Range.Text = DisplayTxt
    End With
            Else: fldItemIND = 0
           End If
     Next
           'Get next linked story (if any)
           Set rngStory = rngStory.NextStoryRange
       Loop Until rngStory Is Nothing
    Next
Selection.Collapse
'Get Screentip text
n = 0
fcDisplay.ShowFieldCodes = True
For Each rngStory In oDoc.StoryRanges
       'Iterate through all linked stories
       Do
           'Find only the AutoTextList fields
            fldItemIND = 0
            For Each fldItem In rngStory.Fields
            If fldItem.Type = wdFieldAutoTextList Then
            fldItemIND = 1
              n = n + 1
              Dim strTip() As String
              strTip = Split(fldItem.Code.Text, """")
              ScreenTipTxt = strTip(1)
                       
  With oTable.Rows(n + 2)
    ' .Cells(3).Range.Text = ScreenTipTxt
     oTable.Cell(n + 2, 3).Range.Text = ScreenTipTxt
    End With
              
          
          End If
          
    Next
           'Get next linked story (if any)
           Set rngStory = rngStory.NextStoryRange
       Loop Until rngStory Is Nothing
    Next
Selection.Collapse
fcDisplay.ShowFieldCodes = False
End Sub
Function Count_Auto_Text_List_Fields(Optional CountATL As Long)
Dim lngJunk As Long
Dim fldItem As Word.Field
Dim rngStory As Word.Range
'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 fldItem In rngStory.Fields
        If fldItem.Type = wdFieldAutoTextList Then 'Count only the Ref fields
            CountATL = CountATL + 1
        End If
    Next
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
    Next
    Count_Auto_Text_List_Fields = CountATL
End Function