Search code examples
vbams-wordhyperlinkcomments

In VBA, how do I add a hyperlink to my comment object?


I am trying to create macros in Word to insert comments I frequently need to add to my documents. I want to be able to add text, and below a hyperlink that leads to the source where this text was taken.

Here what the code looks like. I suspect the problem is with the ActiveDocument.Hyperlink.Add part, but I can't find a solution to make my macro target the active comment object rather than the ActiveDocument...

Sub new_comment()
'
' new_comment Macro
'
'
Selection.Comments.Add Range:=Selection.Range, Text:= \_
"This is my text."
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= \_
"https://google.com" \_
, SubAddress:="", ScreenTip:="", TextToDisplay:="This is my source"

End Sub

Any ideas?

I tried manually adding the anchor text and the hyperlink while recording a macro and it didn't register my commands.

=== UPDATE ===

Tim's solution below works well, then I tried adding multiple code blocks, one for each preset comment I want to run in Word. Every subsequent comment I add using these macros will insert the hyperlink anchor in the first comment of the document.

So, if I run the three macros below in order, new_comment_1 and new_comment_2 would anchor their hyperlink somewhere in new_comment. Any ideas on how to fix this?

Sub new_comment()

    Dim cmt As Comment

    Set cmt = Selection.Comments.Add(Range:=Selection.Range, _
                Text:="This is my text. This is my source.")
    
    HyperlinkComment cmt, "This is my source", "https://google.com"
    
End Sub

Sub HyperlinkComment(cmt As Comment, linkText As String, URL As String)
    Dim p As Long, rng As Range
    Set rng = cmt.Range
    p = InStr(1, cmt.Range.Text, linkText, vbTextCompare)
    If p > 0 Then
        rng.SetRange Start:=p, End:=p + Len(linkText)
        cmt.Parent.Hyperlinks.Add Anchor:=rng, Address:=URL
    End If
End Sub

Sub new_comment_1()

    Dim cmt As Comment

    Set cmt = Selection.Comments.Add(Range:=Selection.Range, _
                Text:="This is my second preset comment. This is my second source.")
    
    HyperlinkComment cmt, "This is my second source.", "https://www.wikipedia.org/"
    
End Sub

Sub new_comment_2()

    Dim cmt As Comment

    Set cmt = Selection.Comments.Add(Range:=Selection.Range, _
                Text:="This is my third preset comment. This is my third source.")
    
    HyperlinkComment cmt, "This is my third source.", "https://www.un.org/en/"
    
End Sub

Solution

  • EDIT: updated - removed the SetRange call in HyperlinkComment and used MoveStart / MoveEnd instead, which seems to have fixed things.

    Something like this:

    Sub Tester()
     
        Dim doc As Document, i As Long
        
        
        Set doc = ThisDocument
        
        'for testing - remove any existing comments
        For i = doc.Comments.Count To 1 Step -1
            doc.Comments(i).Delete
        Next i
        
        new_comment doc.Paragraphs(1).Range, "This is my text. This is my source....", _
                    "This is my source", "https://google.com"
                    
        
        new_comment doc.Paragraphs(3).Range, "This is my text2. This is my source2....", _
                    "This is my source", "https://yahoo.com"
                                
        
        new_comment doc.Paragraphs(5).Range, "This is my text3. This is my source3....", _
                    "This is my source", "https://www.wikipedia.org"
    
    
    End Sub
    
    
    Sub new_comment(rng As Range, txt As String, linktxt As String, URL As String)
    
        Dim cmt As Comment
    
        Set cmt = rng.Parent.Comments.add(Range:=rng, Text:=txt)
        HyperlinkComment cmt, linktxt, URL
        
    End Sub
    
    Sub HyperlinkComment(cmt As Comment, linkText As String, URL As String)
        Dim p As Long, rng As Range, cmtLen As Long, p2 As Long
        Set rng = cmt.Range
        cmtLen = Len(rng.Text)
        p = InStr(1, cmt.Range.Text, linkText, vbTextCompare)
        p2 = p + Len(linkText)
        If p > 0 Then
            rng.MoveStart wdCharacter, p - 1
            If p2 < cmtLen Then rng.MoveEnd wdCharacter, -(cmtLen - p2) - 1
            cmt.Parent.Hyperlinks.add Anchor:=rng, Address:=URL
        End If
    End Sub