I have the following code that builds a string of MS word pages that contain track changes (markup). At the end of the loop I exit where track changes are contained on the last page.
However where there are no track changes on the last page I am stuck in a loop (no pun intended). During the run I get the confirmation box 'do you want to start the the beginning of the document' and it loops
How can I add an 'exit do', so where the last track changes are found (not on the last page) the do statement is exited?
Sub finaltest()
Dim CurPage As Integer
Dim totalPages As Integer
Dim Pages As String
'declare variables
Pages = ""
'total page count
ActiveDocument.Repaginate
totalPages = ActiveDocument.BuiltInDocumentProperties(wdPropertyPages)
'get us home
Selection.HomeKey Unit:=wdStory
Do
'find next change
WordBasic.NextChangeOrComment
'get current page
CurPage = Selection.Information(wdActiveEndAdjustedPageNumber)
Pages = Pages & ", " & CurPage
'<exit loop if there is no more track changes and not at last page>
Loop Until CurPage = totalPages
Pages = Right(Pages, Len(Pages) - 2)
MsgBox Pages
End Sub
It is a bit unclear which revision elements you really need to track as far as you use WordBasic.NextChangeOrComment instruction.
However, assuming that you need to track revisions but not comments you could insert the code below right after the comment you put to your Sub:
'<exit loop if there is no more track changes and not at last page>
With ActiveDocument.Content.Revisions
If Selection.Range = .Item(.Count).Range Then
'MsgBox "Last one" - for test only
Exit Do
End If
End With
If you need to trace comments to you need to create similar solution as for revision items (Comments collection doesn't include Revisions collection and vice-versa).
Related
I'm attempting to write a macro in Word that inserts a marker at the beginning of each page in tiny font so it doesn't bump any text forward to the next page. (I then output the document to HTML and do some additional processing of the markers there in Javascript.)
I have basically figured out the script to do that:
Sub Test()
Dim PageCounter As Long
Dim FirstPageInput As String
Dim PageFirstWordRange As Range
Dim InsertWord As String
FirstPageInput = InputBox("What is the initial page number for this article?", "First Page Number?")
For PageCounter = 1 To ActiveDocument.BuiltInDocumentProperties("Number of Pages")
Set PageFirstWordRange = ActiveDocument.Range.GoTo(wdGoToPage, wdGoToAbsolute, PageCounter)
'If this is the first page, add the initial page number. Otherwise, just insert a marker.'
If PageCounter = 1 Then
InsertWord = "!#" + FirstPageInput + "#! "
PageFirstWordRange.InsertBefore (InsertWord)
Else
'PageFirstWordRange.MoveEnd wdCharacter, -1'
InsertWord = " !##! "
PageFirstWordRange.InsertAfter (InsertWord)
End If
'Select the word we just inserted, and change its size to 1'
With PageFirstWordRange.Font
.Size = 1
End With
Next
End Sub
The issue is that there are sometimes pages and pages filled up with footnotes. Because the script tries to find the first word on each page, it ends up skipping these footnote pages (not writing a marker for them) and I need the script to do that.
The solution I've decided is to count the words on each page as I iterate. If there are any pages with 0 text (not including the footnotes) then I will add an additional marker for each blank page.
I have no idea how to do this - I'm so bad with VBA. Does anyone have a solution for me? This feels like an easy thing to do, but I'm pulling my hair out!
I hope my first post will be OK and not offend (I've tried to follow the guide and done a lot of searching).
I've modified the below code from Greg Maxey (https://gregmaxey.com/word_tip_pages/word_fields.html) to update links in my Word document to an Excel workbook. It seems to be the most used code for this purpose. The reason I changed his code was to try to do away with the need to have a counter variable like i, and using a For i = 1 to .Fields.Count Then... Next i structure.
When I run it as is, it gets stuck in a loop only updating the first field in the Word document. To see this, I put in the Debug.Print wrdField.Index line. It repeatedly outputs 1, so it is not moving to the Next wrdField as I expect (the code actually just used Next, but it's the same result if I use Next wrdField).
When I comment out .AutoUpdate = False, it works properly:
Public Sub UpdateExternalLinksToCurrentFolder()
Dim wrdDocument As Word.Document
Dim wrdField As Word.Field
Dim strCurrentLinkedWorkbookPath, strNewLinkedWorkbookPath As String
Dim strCurrentLinkedWorkbookName, strNewLinkedWorkbookName As String
Dim strCurrentLinkedWorkbookFullName, strNewLinkedWorkbookFullName As String
Dim strThisDocumentPath As String
'On Error GoTo ErrorHandler_UpdateExternalLinksToCurrentFolder
Application.ScreenUpdating = False
Set wrdDocument = ActiveDocument
strThisDocumentPath = wrdDocument.Path & Application.PathSeparator
strNewLinkedWorkbookPath = strThisDocumentPath
With wrdDocument
For Each wrdField In .Fields
With wrdField
If .Type = wdFieldLink Then
With .LinkFormat
Debug.Print wrdField.Index
strCurrentLinkedWorkbookPath = .SourcePath & Application.PathSeparator
strCurrentLinkedWorkbookName = .SourceName
strNewLinkedWorkbookName = strCurrentLinkedWorkbookName
strNewLinkedWorkbookFullName = strNewLinkedWorkbookPath & strNewLinkedWorkbookName
.AutoUpdate = False
End With
.Code.Text = VBA.Replace(.Code.Text, Replace(strCurrentLinkedWorkbookPath, "\", "\\"), Replace(strNewLinkedWorkbookPath, "\", "\\"))
End If
End With
Next
End With
Set wrdDocument = Nothing
Application.ScreenUpdating = True
Exit Sub
Can anyone tell my why it's behaving this way? When I set .AutoUpdate = False, am I changing something about the link field or doing something to the Word document that causes the .wrdField.Index to reset to 1? I can't find anything online documenting this behavior and it's driving me nuts.
Behind the scenes, what's happening is that Word recreates the content and the field. The orginal linked content is removed and new content inserted. So that essentially destroys the field and recreates it. A user won't notice this, but VBA does.
When dealing with a loop situation that uses an index and the looped items are being removed, it's therefore customary to loop backwards (from the end of the document to the beginning). Which cannot be done with For...Each.
I have built - over the years - a vba macro that is supposed to update all fields in a word document.
I invoke this macro before releasing the document for review to ensure all headers and footers etc are correct.
Currently - it look like this:
Sub UpdateAllFields()
'
' UpdateAllFields Macro
'
'
Dim doc As Document ' Pointer to Active Document
Dim wnd As Window ' Pointer to Document's Window
Dim lngMain As Long ' Main Pane Type Holder
Dim lngSplit As Long ' Split Type Holder
Dim lngActPane As Long ' ActivePane Number
Dim rngStory As Range ' Range Objwct for Looping through Stories
Dim TOC As TableOfContents ' Table of Contents Object
Dim TOA As TableOfAuthorities 'Table of Authorities Object
Dim TOF As TableOfFigures 'Table of Figures Object
Dim shp As Shape
' Set Objects
Set doc = ActiveDocument
Set wnd = doc.ActiveWindow
' get Active Pane Number
lngActPane = wnd.ActivePane.Index
' Hold View Type of Main pane
lngMain = wnd.Panes(1).View.Type
' Hold SplitSpecial
lngSplit = wnd.View.SplitSpecial
' Get Rid of any split
wnd.View.SplitSpecial = wdPaneNone
' Set View to Normal
wnd.View.Type = wdNormalView
' Loop through each story in doc to update
For Each rngStory In doc.StoryRanges
If rngStory.StoryType = wdCommentsStory Then
Application.DisplayAlerts = wdAlertsNone
' Update fields
rngStory.Fields.Update
Application.DisplayAlerts = wdAlertsAll
Else
' Update fields
rngStory.Fields.Update
If rngStory.StoryType <> wdMainTextStory Then
While Not (rngStory.NextStoryRange Is Nothing)
Set rngStory = rngStory.NextStoryRange
rngStory.Fields.Update
Wend
End If
End If
Next
For Each shp In doc.Shapes
If shp.Type <> msoPicture Then
With shp.TextFrame
If .HasText Then
shp.TextFrame.TextRange.Fields.Update
End If
End With
End If
Next
' Loop through TOC and update
For Each TOC In doc.TablesOfContents
TOC.Update
Next
' Loop through TOA and update
For Each TOA In doc.TablesOfAuthorities
TOA.Update
Next
' Loop through TOF and update
For Each TOF In doc.TablesOfFigures
TOF.Update
Next
' Header and footer too.
UpdateHeader
UpdateFooter
' Return Split to original state
wnd.View.SplitSpecial = lngSplit
' Return main pane to original state
wnd.Panes(1).View.Type = lngMain
' Active proper pane
wnd.Panes(lngActPane).Activate
' Close and release all pointers
Set wnd = Nothing
Set doc = Nothing
End Sub
Sub UpdateFooter()
Dim i As Integer
'exit if no document is open
If Documents.Count = 0 Then Exit Sub
Application.ScreenUpdating = False
'Get page count
i = ActiveDocument.BuiltInDocumentProperties(14)
If i >= 1 Then 'Update fields in Footer
For Each footer In ActiveDocument.Sections(ActiveDocument.Sections.Count).Footers()
footer.Range.Fields.Update
Next
End If
Application.ScreenUpdating = True
End Sub
'Update only the fields in your footer like:
Sub UpdateHeader()
Dim i As Integer
'exit if no document is open
If Documents.Count = 0 Then Exit Sub
Application.ScreenUpdating = False
'Get page count
i = ActiveDocument.BuiltInDocumentProperties(14)
If i >= 1 Then 'Update fields in Header
For Each header In ActiveDocument.Sections(ActiveDocument.Sections.Count).Headers()
header.Range.Fields.Update
Next
End If
Application.ScreenUpdating = True
End Sub
I have noticed recently that it sometimes misses some sections of the document. Today it missed First page footer -section 2- (the document version was not updated).
I have built this macro over a number of years and several bouts of research but I am not proud of it so please suggest a complete replacement if there is now a clean way of doing it. I am using Word 2007.
To test, create a word document and add a custom field named Version and give it a value. Then use that field {DOCPROPERTY Version \* MERGEFORMAT } in as many places as you can. Headers, Footers, first-page, subsequent page etc. etc. Remember to make a multi-section document with different header/footers. Then change the property and invoke the macro. It currently does quite a good job, handling TOCs and TOAs an TOFs etc, it just seems to skip footers (sometimes) in a multi-section document for example.
Edit
The challenging document that seems to cause the most problems is structured like this:
It has 3 sections.
Section 1 is for the title page and TOC so the first page of that section has no header/footer but does use the Version property on it. Subsequent pages have page numbering in roman numerals for the TOC.
Section 2 is for the body of the document and has headers and footers.
Section 3 is for the copyright blurb and this has a very strange header and a cut-down footer.
All footers contain the Version custom document property.
My code above seems to work in all cases except sometimes it misses first page footer of sections 2 and 3.
For years, the standard I've used for updating all fields (with the exception of TOC, etc. which are handled separately) in a document is the one the Word MVPs use and recommend, which I'll copy here. It comes from Greg Maxey's site: http://gregmaxey.mvps.org/word_tip_pages/word_fields.html. One thing it does that I don't see in your version is update any fields in Shapes (text boxes) in the header/footer.
Public Sub UpdateAllFields()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
On Error Resume Next
rngStory.Fields.Update
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
oShp.TextFrame.TextRange.Fields.Update
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
End Sub
Some research and experimentation produced the following addition which seems to solve the additional problem of updating the headers/footers in a multi-section document.
Add the following dimensions to the earlier answer:
dim sctn as Word.Section
dim hdft as Word.HeaderFooter
And then, add to the earlier code
for each sctn in doc.Sections
for each hdft in sctn.Headers
hdft.Range.Fields.Update
next
for each hdft in sctn.Footers
hdft.Range.Fields.Update
next
next
However - I am still not happy with this code and would very much like to replace it with something less hacky.
Thanks for these answers! I found the answers very good and learned some stuff about ms-word macros. I thought I'd make my own answer for consideration (and adding some more search engine keywords - my searches didn't bring me here immediately).
I took inspiration from the citations in the footnotes.
I had an issue where MS Word fields were not updating in Textbox (Shapes).
I was working on a 70 page word document (Word 2013) that contained a lot of figures/images/captions and cross-references. A common practice is for an image to be captioned e.g. Figure 7, so it can be easily cross-referenced. Often the caption is inside a textbox (shape) and grouped with/to the object its captioning.
So after some document editing and content reorganisation, the fields and cross-references can easily get out of logical sequence.
OK - no problem... pressing CTRL+A then F9 to update the document fields should solve this?
Unfortunately that didn't work as expected to update fields in textboxes (shapes).
In this scenario where fields exist inside textboxes (shapes) CTRL+A then F9 only updated the fields not inside a textbox (shape).
One can assume this behaviour is because field updating (F9) works on selected text, and with the CTRL+A then F9 approach only text outside of the textboxes (shapes) is selected, so the field update only applies outside of textboxes (shapes).
I'm surprised there is not a button on the ribbon to perform an "update all fields". There could even be a toggle option to prompt the user to update all fields when closing a document?
I checked Word's (2013) ribbon command list, and didn't find an Update All command.
Solution UpdateAllFields()
Like the code shared by #Cindy here, the following code should update fields wherever they are in the doc, header, footer, main doc, textbox, grouped and nested grouped textbox.
Create a macro with the following code, and then add to the Quick Access Toolbar (QAT)
Press ALT+F8 to open the Macros dialogue.
Enter a name for the Macro: UpdateAllFields
Press Create button
Paste the code:
Sub UpdateAllFields()
Application.ScreenUpdating = False
With ActiveDocument
.Fields.Update
.PrintPreview
.ClosePrintPreview
End With
Application.ScreenUpdating = True
End Sub
Finally add the Macro to the Quick Access Toolbar.
Citations and inspirations:
The Q&A's in this post!
There is a related post on the Microsoft Community here: Word 365 Fields not updating in Textbox [serious reproducible error]. This suggests the issue is present in at least Word 2013 and Word 365.
There is a related post on Stack Overflow here: Macro to update fields in shapes (textboxes) in footer in Microsoft Word.
Another example UpdateTextboxFields()
This was the first version of code I wrote as I was in research and solution mode. Its a recursive approach to update fields inside textboxes, even if they are inside a group, or nested group. This doesn't update fields outside shapes.
Public Sub UpdateTextboxFields()
Application.ScreenUpdating = False
With ActiveDocument
Call IterateShapesCollection(.Shapes)
.PrintPreview
.ClosePrintPreview
End With
Application.ScreenUpdating = True
End Sub
Private Sub IterateShapesCollection(col)
Dim shp As Shape
For Each shp In col
' https://learn.microsoft.com/en-gb/office/vba/api/office.msoshapetype
' Ignore images and
If 1 = shp.Type Or 13 = shp.Type Then
GoTo NextIteration
End If
'Debug.Print ("Name: " & shp.Name & ", Type: " & shp.Type)
' if the type is a group, recurse
If 6 = shp.Type Then
Call IterateShapesCollection(shp.GroupItems)
Else
Call UpdateShapeFields(shp)
End If
NextIteration:
Next
End Sub
Private Sub UpdateShapeFields(shp)
With shp.TextFrame
If .HasText Then
.TextRange.Fields.Update
End If
End With
End Sub
Word display option: Update fields before printing
cite: Microsoft article Some fields are updated while other fields are not
The concept behind this option/approach is: all document fields are updated when you open print preview.
It looks like this option in Word (tested in 2013) updates all fields with a caveat - see below - you may need to open and close print preview twice.
File → Options → Display → Print options section → Update fields before printing
Caveat if the doc has cross-references to figures/captions
This caveat applies to the word "Update fields before printing" display option and the UpdateAllFields() macro.
IF the document contains cross-references to figures/captions (with numbers), and those figures/captions have changed sequence/place in the document...
You must update the fields twice, 1) to reflect the figures/captions update, and then 2) to update the cross-references.
I'm basically trying to create a cumulative word count for documents that will put the number of words on each page into its footer and add it to the total words each page. After a lot of looking around, I found that Word doesn't really handle pages the same for everybody and so doesn't have any interface to access the individual pages through.
Now I'm trying to separate each page with page breaks so there's a clear delimiter between pages, but I still can't find how to loop through these. Any clues?
I'm going to post the code I have, but it's only for getting the word count currently. No proper attempts at cycling through page breaks because I don't know how.
Sub getPageWordCount()
Dim iPgNum As Integer
Dim sPgNum As String
Dim ascChar As Integer
Dim rngPage As Range
Dim iBeginPage As Integer
Dim iEndPage As Integer
' Go to start of document and make sure its paginated correctly.
Selection.HomeKey Unit:=wdStory, Extend:=wdMove
ActiveDocument.Repaginate
' Loop through the number of pages in the document.
For iPgNum = 2 To Selection.Information(wdNumberOfPagesInDocument)
sPgNum = CStr(iPgNum)
iBeginPage = Selection.Start
' Go to next page
Selection.GoTo wdGoToPage, wdGoToAbsolute, sPgNum
' and to the last character of the previous page...
Selection.MoveLeft wdCharacter, 1, wdMove
iEndPage = Selection.Start
' Retrieve the character code at insertion point.
Set rngPage = ActiveDocument.Range(iBeginPage, iEndPage)
MsgBox rngPage.ComputeStatistics(wdStatisticWords)
'rngPage.Footers(wdHeaderFooterPrimary).Range.Text = rngPage.ComputeStatistics(wdStatisticWords)
'ActiveDocument.Sections(2).Footers
' Check the character code for hard page break or text.
Next
' ActiveDocument.Sections(2).Footers(wdHeaderFooterPrimary).Range.Text = "bob" 'Testing
End Sub
Finally got it, managed to guess my way through it a bit, taking assorted bits from dark corners of the internet:
Sub getPageWordCount()
'Replace all page breaks with section breaks
Dim myrange1 As Range, myrangedup As Range
Selection.HomeKey wdStory
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findText:="^m", Forward:=True, _
MatchWildcards:=False, Wrap:=wdFindStop) = True
Set myrange = Selection.Range
Set myrangedup = Selection.Range.Duplicate
myrange.Collapse wdCollapseEnd
myrange.InsertBreak wdSectionBreakNextPage
myrangedup.Delete
Loop
End With
'Unlink all footers and insert word count for each section
Dim sectionCount, sectionNumber, i, sectionWordCount, cumulativeWordCount As Integer
sectionCount = ActiveDocument.Sections.Count
For sectionNumber = 1 To sectionCount
With ActiveDocument.Sections(sectionNumber)
sectionWordCount = .Range.ComputeStatistics(wdStatisticWords)
cumulativeWordCount = cumulativeWordCount + sectionWordCount
With .Footers.Item(1)
.LinkToPrevious = False
.Range.Text = "This page's word count: " + CStr(sectionWordCount) + " | Cumulative word count: " + CStr(cumulativeWordCount)
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
End With
Next
End Sub
And now I've just discovered that if I want to port this macro to an add-in for ease of use for non-techy users I have to write it in VB 2010 in Visual Studio where the API is different. Good luck me!
It sounds as if you have what you need, but I was working on an alternative that I may as well post because it does not require you to add page breaks or section breaks. But you would have to add the same nested field in each footer that appears in the document (I haven't done that part here, but it's not completely trivial because there may be multiple sections and multiple footers per section).
The field code you need to add (in addition to your 'This page's word count: ' text) is
{ DOCVARIABLE "s{ SECTION }p{ PAGE \*arabic }" }
As written, the method may break in some circumstances, e.g. if there are continuous section breaks. I haven't checked.
Sub createWordCounts()
Dim i As Integer
Dim rng As Word.Range
With ActiveDocument
For i = 1 To .Range.Information(wdActiveEndPageNumber)
Set rng = .GoTo(wdGoToPage, wdGoToAbsolute, i).Bookmarks("\page").Range
.Variables("s" & CStr(rng.Information(wdActiveEndSectionNumber)) & "p" & CStr(rng.Information(wdActiveEndAdjustedPageNumber))).Value = rng.ComputeStatistics(wdStatisticWords)
Set rng = Nothing
Next
End With
End Sub
I'm writing a VB Macro to do some processing of documents for my work.
The lines of text are searched and the bracketed text is put in a list(box).
The problem comes when I want to remove all hyperlinks in the document and then generate new ones (not necessarily in the location of the original hyperlinks)
So the problem is How do I remove the existing hyperlinks?
My current issue is that every time a link gets added, the hyperlinks count goes up one, but when you delete it, the count does NOT reduce. (as a result I now have a document with 32 links - all empty except for 3 I put in myself - they do not show up in the document)
At the end of the code are my attempts at removing the hyperlinks.
Private Sub FindLinksV3_Click()
ListOfLinks.Clear
ListOfLinks.AddItem Now
ListOfLinks.AddItem ("Test String 1")
ListOfLinks.AddItem ActiveDocument.FullName
SentenceCount = ActiveDocument.Sentences.Count
ListOfLinks.AddItem ("Sentence Count:" & SentenceCount)
counter = 0
For Each myobject In ActiveDocument.Sentences ' Iterate through each element.
ListOfLinks.AddItem myobject
counter = counter + 1
BracketStart = (InStr(1, myobject, "("))
If BracketStart > 0 Then
BracketStop = (InStr(1, myobject, ")"))
If BracketStop > 0 Then
ListOfLinks.AddItem Mid$(myobject, BracketStart + 1, BracketStop - BracketStart - 1)
ActiveDocument.Sentences(counter).Select
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _
"http://testnolink/" & counter, ScreenTip:="" 'TextToDisplay:=""
End If
End If
Next
'ActiveDocument.Sentences(1).Select
'
'Selection.Range.Hyperlinks(1).Delete
ActiveDocument.Hyperlinks.Item(1).Delete
Debug.Print ActiveDocument.Hyperlinks.Count
End Sub
This is an old post, so am adding this VBA code in case it is useful to someone.
Hyperlinks (Collections) need to be deleted in reverse order:
Sub RemoveHyperlinksInDoc()
' You need to delete collection members starting from the end going backwards
With ActiveDocument
For i = .Hyperlinks.Count To 1 Step -1
.Hyperlinks(i).Delete
Next
End With
End Sub
Sub RemoveHyperlinksInRange()
' You need to delete collection members starting from the end going backwards
With Selection.Range
For i = .Hyperlinks.Count To 1 Step -1
.Hyperlinks(i).Delete
Next
End With
End Sub
The line removing the hyperlink is commented out. The following line will remove the first hyperlink within the selected range:
Selection.Range.Hyperlinks(1).Delete
This will also decrement Selection.Range.Hyperlinks.Count by 1.
To see how the count of links is changing you can run the following method on a document:
Sub AddAndRemoveHyperlink()
Dim oRange As Range
Set oRange = ActiveDocument.Range
oRange.Collapse wdCollapseStart
oRange.MoveEnd wdCharacter
Debug.Print ActiveDocument.Range.Hyperlinks.Count
ActiveDocument.Hyperlinks.Add oRange, "http://www.example.com"
Debug.Print ActiveDocument.Range.Hyperlinks.Count
ActiveDocument.Hyperlinks.Item(1).Delete
Debug.Print ActiveDocument.Range.Hyperlinks.Count
End Sub