How do you remove hyperlinks from a Microsoft Word document? - vba

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

Related

VBA Word; How to resize bookmark label range?

I have messed cross-references to pictures in my word document. The label shows only part of the figure name:
Figure 5-
I have found out that bookmark responsible for that has narrowed range than the full figure name:
[Figure 5-] 62: Caption text
I would like to extend the bookmark label up to ":" using VBA, but I have no idea how to go further with the code.
Bookmark.Start and Bookmark.End refer to the whole picture text so how to refer only to label? my code is as follow:
Sub extend_bookmarks()
Dim bmk As Bookmark
Dim msg As String
Dim pos As Integer
For Each bmk In ActiveDocument.Range.Bookmarks
If (InStr(1, bmk.Range.Text, "Figure") And IsNumeric(Mid(bmk.Range.Text, 8, 1))) Then
pos = InStr(1, bmk.Range.Text, ":")
If ((pos < 12) And (pos > 0)) Then
Debug.Print bmk.Name
Debug.Print bmk.Range.Text
Debug.Print bmk.End - bmk.Start; pos
End If
End If
Next bmk
End Sub
You could just reapply the bookmark using the paragraph it sits in as the range.
Sub extend_bookmarks()
Dim bmk As Variant
For Each bmk In ActiveDocument.Range.Bookmarks
ActiveDocument.Bookmarks.Add Range:=bmk.range.Paragraphs(1).range, Name := bmk.Name
Next
End Sub
Update, When I tested the code above I only stepped through the loop twice and so missed the obvious, that you cannot use 'for each' when you are changing the content of a collection.
The code below correctly extends the bookmarks as intended and does not crash word.
Sub extend_bookmarks()
Dim myCount As Long
myCount = ActiveDocument.Bookmarks.Count
Dim myIndex As Long
With ActiveDocument.Bookmarks
For myIndex = myCount To 1 Step -1
.Add Range:=.Item(myIndex).Range.Paragraphs(1).Range, Name:=.Item(myIndex).Name
Next
End With
End Sub

Word VBA: how to select found text rather than where the cursor is positioned

This is probably simple but I can't get it to work.
I need to search through my document, find words that contain the string 'alog' and add 'ue'. For example, 'catalogs' --> 'catalogues'.
The above works fine but I can't get the next bit to work: if a found string already has 'ue' after the 'log' I don't want to add another 'ue'.
The subroutine accessed from the macro is below. I've tried adding the following lines into the 'while execute' part, but 'selection' always turns out to be the word where the cursor happens to be.
With Selection
.Expand unit:=wdWord
End With
How do I i) select the content of the found range and ii) expand that new selection by two characters to see if those two characters are 'ue' ?
Many thanks.
Sub do_replace2(old_text As String, new_text As String, Count_changes As Integer)
' Replaces 'log' with 'logue'
' Ignores paragraphs in styles beginning with 'Question'
Dim rg As Range
Set rg = ActiveDocument.Range
With rg.Find
.Text = old_text
While .Execute
If Left(rg.Paragraphs(1).Style, 8) <> "Question" Then
rg.Text = new_text
With ActiveDocument.Comments.Add(rg, "Changed from '" & old_text & "'")
.Initial = "-logs"
.Author = "-logs"
End With
Count_changes = Count_changes + 1
End If
rg.Collapse wdCollapseEnd
Wend
End With
End Sub
I'm not quite sure I follow the first part of your question "How do I select the content of the found range". The rg variable already contains the search result. If you want to select it, just use rg.Select. This might be useful in debugging (so you can see where the Range is when you're stepping through the code), but there isn't really any other reason to use the Selection object in the code from your question. You can just use the Range object instead.
As to part 2 of your question "How do I ... expand that new selection by two characters", all you need to do is add 2 to the .End property of the Range. Since you're only using this for a test (and because the .Find method can be dodgy), test this on a copy of rg:
With rg.Find
.Text = old_text
While .Execute
If Left(rg.Paragraphs(1).Style, 8) <> "Question" Then
Dim test As Range
Set test = rg.Duplicate 'copy the found Range.
test.Collapse wdCollapseEnd 'move to the end of it.
test.End = test.End + 2 'expand to the next 2 characters.
If test.Text <> "ue" Then 'see if it's "ue".
rg.Text = new_text
With ActiveDocument.Comments.Add(rg, "Changed from '" & old_text & "'")
.Initial = "-logs"
.Author = "-logs"
End With
Count_changes = Count_changes + 1
End If
End If
rg.Collapse wdCollapseEnd
Wend
End With

Using word wildcards to find unaccepted changes

I have some word documents with unaccepted, tracked changes. I want to accept them but still have them shown in red in my documents. I think a good way to do this would be doing a wildcard search for unaccepted changes and replacing them with the same text in red, however I dont know if this is possible.
I am also happy with other ways of achieving my goal, without wildcards.
Applying formatting to revisions cannot be done using Word's standard find & replace operation. However, you can write a macro that enumerates all revisions and then applies formatting to each of them.
There is a bloc post by Chris Rae who provides a macro that converts revisions to standard formatting:
Enumerating edits on large documents (AKA converting tracked changes to conventional formatting)
The macro may not yet do exactly what you need, but it should get you started.
For reference, here is a copy of the macro:
Sub EnumerateChanges()
Dim rAll As Revision
Dim dReport As Document
Dim dBigDoc As Document
Set dBigDoc = ActiveDocument
If dBigDoc.Revisions.Count = 0 Then
MsgBox "There are no revisions in the active document.", vbCritical
ElseIf MsgBox(“This will enumerate the changes in '" + dBigDoc.Name + "' in a new document and close the original WITHOUT saving changes. Continue?", vbYesNo) <> vbNo Then
Set dReport = Documents.Add
dBigDoc.Activate ' really just so we can show progress by selecting the revisions
dBigDoc.TrackRevisions = False ' Leaving this on results in a disaster
For Each rAll In dBigDoc.Revisions
' Now find the nearest section heading downwards
Dim rFindFirst As Range, rFindLast As Range
Set rFindLast = rAll.Range.Paragraphs(1).Range
While Not IsNumberedPara(rFindLast.Next(wdParagraph))
Set rFindLast = rFindLast.Next(wdParagraph)
Wend
' Now head back up to the next numbered section header
Set rFindFirst = rFindLast
Do
Set rFindFirst = rFindFirst.Previous(wdParagraph)
Loop Until IsNumberedPara(rFindFirst) Or (rFindFirst.Previous(wdParagraph) Is Nothing)
ConvertNumberedToText rFindFirst
Dim rChangedSection As Range
Set rChangedSection = dBigDoc.Range(rFindFirst.Start, rFindLast.End)
' Properly tag all the revisions in this whole section
Dim rOnesInThisSection As Revision
For Each rOnesInThisSection In rChangedSection.Revisions
rOnesInThisSection.Range.Select ' just for visual update
DoEvents ' update the screen so we can see how far we are through
If rOnesInThisSection.Type = wdRevisionDelete Then
rOnesInThisSection.Reject
With Selection.Range
.Font.ColorIndex = wdRed
.Font.StrikeThrough = True
End With
dBigDoc.Comments.Add Selection.Range, “deleted”
Else
If rOnesInThisSection.Type = wdRevisionInsert Then
rOnesInThisSection.Accept
With Selection.Range
.Font.ColorIndex = wdBlue
End With
dBigDoc.Comments.Add Selection.Range, “inserted”
End If
End If
Next
' Now copy the whole thing into our new document
rChangedSection.Copy
Dim rOut As Range
Set rOut = dReport.Range
rOut.EndOf wdStory, False
rOut.Paste
Next rAll
' There should end up being no numbered paragraphs at all in the
' new doc (they were converted to text), so delete them
Dim pFinal As Paragraph
For Each pFinal In dReport.Paragraphs
If IsNumberedPara(pFinal.Range) Then
pFinal.Range.ListFormat.RemoveNumbers
End If
Next
dBigDoc.Close False
End If
End Sub
Sub ConvertNumberedToText(rOf As Range)
If InStr(rOf.ListFormat.ListString, “.”) > 0 Then
rOf.InsertBefore "Changes to section " + rOf.ListFormat.ListString + " "
End If
End Sub
Function IsNumberedPara(rOf As Range) As Boolean
If rOf Is Nothing Then ‘ if the document doesn’t have numbered sections, this will cause changes to be enumerated in the whole thing
IsNumberedPara = True
ElseIf rOf.ListFormat.ListString <> "" Then
If Asc(rOf.ListFormat.ListString) <> 63 Then
IsNumberedPara = True
End If
End If
End Function

VBA Word: How can I find in which table something (i.e. selection) is?

I have in my word document many tables, each is linked to bookmark.
Then I have function which scan document for each tracked change (revisions).
How can I find out where my tracked change is? in which table?
Here is some of my code:
Dim ThisWord As Document, TabHead As Table
Set ThisWord = ActiveDocument
Set TabHead = ThisWord.Bookmarks("Head").Range.Tables(1) '"Head" is bookmark for my first table
For Each oRevision In ThisWord.Revisions 'Run through each revision - tracked change
Select Case oRevision.Type
Case wdRevisionInsert
strText = oRevision.Range.Text
If oRevision.Range.Information(wdWithInTable) = True Then 'Check if tracked change is within table
Select Case oRevision.Range.Table ' <-- How can I change this part???
Case TabHead
'do some stuff with strText
'Case AnotherTable1
'Case AnotherTable2
'...
end select
end if
end select
next oRevision
My main goal is to track down all changes in word document, get date and time and user of that change. By I need to know where that change was made. Tracked change function can give me all that detail, but how to determine where that change was made?
Through the Range object, you have acces to all the different objects in the revision. If you want to reference the first Table object then use:
oRevision.Range.Tables(1)
You obviously need to check to see that there are tables before using the reference (e.g If oRevision.Range.Tables.Count > 0 Then ...).
You could also access the bookmarks collection in the same way:
If oRevision.Range.Bookmarks.Count > 0 Then
Debug.Print oRevision.Range.Bookmarks(1).Name
End If
This gives you the table number of Selection.
Sub Demo()
Dim iTable&
With Selection
If Not .Information(wdWithInTable) Then
MsgBox "The selection is not in a table!"
Exit Sub
End If
For iTable = 1 To ActiveDocument.Tables.Count
If (.Range.Start >= ActiveDocument.Tables(iTable).Range.Start) And _
(.Range.End <= ActiveDocument.Tables(iTable).Range.End) Then
Exit For
End If
Next iTable
End With
MsgBox "It's in table # " & iTable
End Sub
From macropod https://groups.google.com/forum/#!searchin/microsoft.public.word.programming/%22table%22$20which/microsoft.public.word.programming/Gid7abgeAek/c5rUWhFmWwgJ

Loop through pages OR page breaks?

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