I'm trying to make a VBA script that will take all the headings in a document and make a table of contents out of them, with hyperlinks to each of the headings. The headings are all found, parsed and all the hyperlinks are made, however they don't correctly reach their destination which is a place within the document. The default 'create hyperlink to Place in this document' code looks like this:
Selection.Range.Hyperlinks(1).Range.Fields(1).Result.Select
Selection.Range.Hyperlinks(1).Delete
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
SubAddress:="_Test_Heading"
Selection.Collapse Direction:=wdCollapseEnd
This is the code that you would get if you recorded a macro while using the 'Edit hyperlink' window.
Edit hyperlink window
The address field where normally there would be a URL is empty, while the subaddress field is filled by the name of the header with underscores.
I think the problem is that Word defaults to 'Existing file or web page' rather than 'Place in this document', even if 'Place in this document' were specified prior. If I switch the mode of a link to 'Place in this document' without changing the subaddress or anything else, it works - but having to go and do that for each link defeats the purpose of the script. I've been looking all over for a way to express 'Place in this document' in VBA but haven't found anything. Tried bookmarks as an alternative and that didn't work either. Any help would be appreciated.
I found a workaround using cross-referencing. In case it helps anyone in the future:
Private Function GetLevel(strItem As String) As Integer
Dim strTemp As String
Dim strOriginal As String
Dim longDiff As Integer
strOriginal = RTrim$(strItem)
strTemp = LTrim$(strOriginal)
longDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (longDiff / 2) + 1
End Function
Sub TableofContents()
Dim i As Integer
Dim AllHeadings As Variant
AllHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeHeading)
Selection.HomeKey Unit:=wdStory
Selection.HomeKey Unit:=wdLine
For i = LBound(AllHeadings) To UBound(AllHeadings)
strtext = Trim$(AllHeadings(i))
Level = GetLevel(CStr(AllHeadings(i)))
If Level = 2 Then
Selection.InsertCrossReference ReferenceType:="Heading", ReferenceKind:= _
wdContentText, ReferenceItem:=i, InsertAsHyperlink:=True, _
IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
Selection.TypeParagraph
End If
Next
End sub
The first function gets the level of the heading.
The second part moves to the top of the document and starts inserting cross-references to the headings that I want (in this case I want it to be = 2).
Related
I need to add a hyperlink to a bookmark in an MS-Word template. The hyperlink (which changes depending on user input) points to an entry in a database on the web. I have no trouble building the hyperlink as a string variable, but I can't figure out how to put it in the bookmark so the user winds up with a Word document containing a link that can be clicked to go to the database entry. My code (below) just deletes the bookmark. What am I missing?
Dim databaseURL As String
' get databaseURL from an existing variable--this part works OK
databaseURL = ActiveDocument.Variables("databaseLink")
' put the hyperlink in a bookmark named "linkToDatabase"
Dim BMRange As Range
Set BMRange = ActiveDocument.Bookmarks("linkToDatabase").Range
BMRange.Text = "Database link"
ActiveDocument.Hyperlinks.Add Anchor:=BMRange, _
Address:=databaseURL, _
SubAddress:="", ScreenTip:="", TextToDisplay:=BMRange.Text
What you could do to simplify things is to have a bookmarked 'default' hyperlink field at the bookmarked range, then simply change the hyperlink field's code. For example:
ActiveDocument.Bookmarks("linkToDatabase").Range.Fields(1).Code.Text = "HYPERLINK " & databaseURL
I'm trying to fix the hyperlinks in a Word document. I need to change the SubAddress property of some hyperlinks. To that end, I'm looping through them. Unfortunately, I get a very weird error saying method 'subaddress' of object 'hyperlink' failed when I try to change any SubAddress. Apparently this happens because something is broken with VBA itself.
Sub FixHyperlinks()
'
' FixHyperlinks Macro
'
'
ActiveDocument.Hyperlinks(1).SubAddress = "some new subaddress"
End Sub
I'm rocking Office 2016 Professional Plus. Can anybody tell me if this works for you?
It's easy to test. Just create a new document, type two one-word lines. Make the second line style "Heading 1". Go to first line, hit CTRK + K (to create hyperlink) point it to "a place in this document", select the heading you just created. DO NOT enter any address. Now go to Macros, paste the above and hit F5 while your caret is inside the code.
The hyperlink works fine when clicked with the mouse (first line hyperlink will take you to the 2nd line Heading).
Although Hyperlink.SubAddress Property is supposed to be a read/write string, writing to it fails - even in Word 2010. Try something along the lines of:
Dim Rng As Range, StrAddr As String, StrTxt As String
With ActiveDocument
With .Hyperlinks(1)
Set Rng = .Range
StrAddr = .Address
StrTxt = .TextToDisplay
.Delete
End With
.Hyperlinks.Add Anchor:=Rng, Address:=StrAddr, SubAddress:="new_sub_address"
End With
I have a userform where I will be wanting people to enter a link e.g. bbc.com & I want the program to automatically turn this string into a hyperlink (blue underlined) called "website".
Here's what I have so far.
PublicProperty Get Link() as string
Link=Me.Linkbvalue
.cells(blankrow,1).value=me.link
EDIT: Note, words generic to protect company. Actually the problem is not it starting with local server. In the following the file is in the folder but not the subfolder
Entry="\directory\folders_directory\folder\file"
when running code,
address becomes
\directory/folders_directory\folder\sub_folder"\directory\folders_directory\folder\file"
The following might help.
It will convert column A values to hyperlinks.
Sub GetHyperlink()
For Each xCell In Range("A:A")
If xCell.Value <> "" Then
ActiveSheet.Hyperlinks.Add Anchor:=xCell, Address:="http://www." & Replace(xCell.Formula, "www.", ""), TextToDisplay:="Website"
End If
Next xCell
End Sub
This is something that should work, if you read the the entry variable from the Form:
Sub TestMe()
Dim entry As String
entry = "bbc.com"
Dim httpPrefix As String
httpPrefix = "https://"
If Left(entry, Len(httpPrefix)) <> httpPrefix Then
entry = httpPrefix & entry
End If
With Worksheets(1)
.Hyperlinks.Add Anchor:=.Cells(1, 1), _
Address:=entry, _
TextToDisplay:="website"
End With
End Sub
Some business logic is needed to decide whether to write https:// or http:// or anything similar. You may consider using Trim() to remove possible empty cells from the left and the right.
I have the following code to insert a textbox into a word document:
Sub mark()
Dim Box As Shape
Set Box = ActiveDocument.Shapes.AddTextbox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=20, Top:=20, Width:=20, Height:=20)
Box.TextFrame.TextRange.Text = "tick"
End Sub
The text inside the texbox needs to be:
Selection.InsertSymbol Font:="Wingdings", CharacterNumber:=-3844, Unicode :=True
I see you've found an answer, but there's a more optimal way to use the method you found. Since it's not possible to format code nicely in Comments I'm writing it up in the Answer space for you (and others who might have the same question). Also, the site prefers the useful information to be in an "Answer" since Comments tend to be over-looked or deleted...
In order to insert content from the Insert Symbol dialog box, use the InsertSymbol method, which applies to either the Range or the Selection`object.
Using the Rangeobject is always the preferred approach. In order to get a Range object for the text box content, adjust your code something like this:
Sub mark()
Dim Box as Word.Shape
Dim rngBox as Word.Range
Set Box = ActiveDocument.Shapes.AddTextBox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=20, Top:=20, Width:=20, Height:=20, _
Set rngBox = Box.TextFrame.TextRange
rngBox.Text = "tick"
rngBox.Collapse wdCollapseEnd 'focus at end of Range
rngBox.InsertSymbol Font:="Wingdings", CharacterNumber:=-3844, Unicode:=True
End Sub
The Collapse method allows you to continue adding text (optionally with formatting) for as long as you require...
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