#1
|
|||
|
|||
Macro to extract AutoTextList Field Screen Tip text
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. |
#2
|
|||
|
|||
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 |
#3
|
|||
|
|||
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. |
#4
|
|||
|
|||
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) |
#5
|
|||
|
|||
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! |
#6
|
|||
|
|||
Marrick,
To be honest, I've not used information that much myself. You might try: Debug.Print fldItem.Code.Information(wdActiveEndAdjustedPageNu mber) |
#7
|
|||
|
|||
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....
|
#8
|
|||
|
|||
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 |
#9
|
|||
|
|||
Macro to extract AutoTextList Field Screen Tip text
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. |
#10
|
|||
|
|||
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. |
#11
|
|||
|
|||
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!
|
#12
|
|||
|
|||
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? |
#13
|
|||
|
|||
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? |
#14
|
|||
|
|||
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 Code:
MsgBox "There are " & UBound(strFieldData, 2) + 1 & " autotext fields in the processed document." 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. |
#15
|
|||
|
|||
Macro to extract AutoTextList Field Screen Tip text
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. |
Tags |
autotextlist, extract, field |
|
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 |