Macro to extract AutoTextList Field Screen Tip text

Marrick13 · #1 11-28-2014, 12:21 PM

I am trying to build a macro that extracts both the display text and the screen tip text from an AUTOTEXTLIST field and writes it to a separate Word document table.

Since I have been unable to locate approaches that can do this, I thought the way to go was to loop through all AUTOTEXTLIST fields, capture each field’s display text, write it to a table cell, then loop again through the same fields, but with the codes switched on to reveal the screen tip text (which is in quotes). Unfortunately, I am using the selection method, partly because I don’t know how else to get text enclosed by quotes from a string (evidently there is no “collection” for it, unlike hyperlink links).

I got this to work reasonably well in step mode, but in real time, it extracts the display text but only the first screen tip text. At various times in the code to get the string tip text,, the code-driven selection extends well beyond the desired text to include several paragraphs. I thought that by separating the two extracts (display vs screen tip) would alleviate this, but it made no difference.

I’ve attached this latest version which does two loop sequences through a document, one to get the display and the other to get the screen tip. Can someone suggest a fix or an alternative method?

The macro and its test document are attached.

gmaxey · #2 11-28-2014, 03:06 PM

Code:

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

Marrick13 · #3 11-28-2014, 04:33 PM

Brilliant, Greg, just brilliant (although probably just another day in the office for you). I neglected to mention I also wanted to capture the page number on which each AutoTextList field appears. I reserved room on the extract table but got too involved with trying to make the main extract work - can you help me with the page number extract?

Thanks mcuh.

gmaxey · #4 11-28-2014, 06:21 PM

Marrick,

Not brilliant, but I've may have tried to push though more VBA knot holes than you. ;-) The page number presents a different challenge. Take a look at the Information method:

Debug.Print oFld.Code.Information(wdActiveEndPageNumber)

Marrick13 · #5 11-28-2014, 07:41 PM

I'm sure you've pushed through a LOT more VBA knotholes than me. Information method works great, although some of the page results are off by one. Not a big deal; close is good enough (unless you can think of a reason - I added the line 'oTable.Cell(n + 2, 1).Range.Text = fldItem.Code.Information(wdActiveEndPageNumber)' to put the page # in the table.

Thanks for all your GREAT help, Greg!

gmaxey · #6 11-28-2014, 08:06 PM

Marrick,

To be honest, I've not used information that much myself. You might try:
Debug.Print fldItem.Code.Information(wdActiveEndAdjustedPageNu mber)

Marrick13 · #7 11-28-2014, 08:34 PM

That made no difference. I saw online that wdActiveEndPageNumber was buggy; maybe its adjusted cousin is as well. These are apparently the right methods to use for capturing page number. Someone online noted that "Page numbers are slippery things in Word" (http://www.vbaexpress.com/forum/arch...hp/t-7385.html). So I guess it's an inexact art....

gmaxey · #8 11-29-2014, 07:59 AM

Marrick,

I have streamlined your code a bit. Is the page number issue due to have the field code displayed? At least with the sample document you posted the page numbers appear correct here.

Code:

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

Marrick13 · #9 11-29-2014, 08:37 AM

Greg,

I appreciate your attempt to improve the page number capture. Your revision did work with the sample file I sent you. However, when I added screen tip fields to the same sample and ran your revised code, the page numbers were again off by a page. I've attached the sample with new fields and your macro so you can see for yourself.

I think the Microsoft model just doesn't allow for the capture of accurate page numbers in this context.

gmaxey · #10 11-29-2014, 08:51 AM

Marrick,

Try this revision:
oFld.Select 'Add this line
arrTemp(0, lngCOunt) = Selection.Information(wdActiveEndPageNumber) '.Code.Information(wdActiveEndPageNumber)

Show field codes in your document and I think you will see that the page numbers that were reported reflect where the expanded fields lie. With the revision above the true page numbers were returned here.

Marrick13 · #11 11-29-2014, 09:08 AM

That seems to do the trick, Greg. I never thought of doing an array, but I am also not good at construct arrays. I will test it further but so far it looks like you've solved the problem. Thanks very much!

gmaxey · #12 11-29-2014, 09:15 AM

Marrick,

I'm not so good with arrays either but the more I use them the less formidable they become. Same goes for classes.

You may observe here that I used a dynamic array. It way seem odd that I didn't have a primary element for each field. Instead the primary elements were page number, displayed text, and screentip text. Then each primary element had a unique secondary element for each field. So the final arrays dimension was something like this (2, 8) instead of (8, 2). There reason for that is Redim Preserve only preserves the final dimension. Make sense?

Marrick13 · #13 11-29-2014, 09:35 AM

Not really, bu that may be because my brain is frying at the moment (working on another macro that captures screen tips only that are hyperlinked-based, and can use the same code as for the AutoTextList tips with only a few changes).

One thing about your revision...I still want to have a count of the AutoTextList screen tips in the document. For one thing, if the macro is run in a document without any such tips, it produces an error, and for another, I want to display a friendly msgbox that I had in an earlier version. Your 'fcnFieldData' function provides the count in the 'lngCOunt' variable, but for some reason, I can't get that value into the main module. I thought that by declaring a variable above the procedure (just below Option Explicit), its value would be available anywhere within the module. But when stepping thru the code, the variable shows zero in the 'Extract_AutoTextList_ScreenTip' module.

Can't I use your 'fcnFieldData' function to both get the page number AND the screen tip count?

gmaxey · #14 11-29-2014, 09:56 AM

Marrick,

For the first issue simply add the following after the line strFieldData() = fncFieldData:

Code:

strFieldData() = fcnFieldData
  On Error Resume Next
  lngIndex = LBound(strFieldData, 1)
  If Err.Number <> 0 Then
    MsgBox ("There are no AutoTextLink fields in this document."), , "Field Count"
    Exit Sub
  End If
  On Error GoTo 0

If you want to know how many fields there are that is available from the array as well:

Code:

MsgBox "There are " & UBound(strFieldData, 2) + 1 & " autotext fields in the processed document."

The array after processing your new sample text begins life as unallocated array:

Dim strFieldData()

After the function it is allocated and dimensioned as like this:

strFieldData(2, 21). Since the array is zero based, the count of fields is 22.

Marrick13 · #15 11-29-2014, 12:02 PM

Greg,

That code works great - thanks!

And thanks for all the free code and help that you provide online. I'd like to offer you the attached "Count_Column_Items" macro that I cobbled together recently to be able to count the entries in a Word column regardless of whether they are numeric or non-numeric (which =COUNT ignores). I had to work out a way to determine if the cursor was actually inside a table (because wdWithInTable tells VBA the cursor is in a table even when it's to the immediate right of a table, which causes an error when trying to get the column number).

The code might be awkward but it works...feel feel to offer it to others on your site.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to find text and replace with form field containing that text	iiiiifffff	Word VBA	16	06-04-2016 01:47 AM
Macro to find coloured text and replace with form-field/formtext containing that text	tarktran	Word VBA	1	11-26-2014 08:12 AM
Word 2007 Macro Fillin Field to Text	mhblake	Word VBA	5	01-08-2014 08:22 AM
Autotextlist Gone	Wilson	Word	1	04-04-2010 02:44 PM
Extract email address from field	zssteen	Excel	1	06-19-2009 02:32 AM