Adding a hyperlink to an automated email

[ChaosPup]

Hi all,

At the moment I have a system that creates a word doc with some prepopulated details and then sends an automated email to various addresses depending on a selection in the Excel form. It works great. Recently I was asked to include a hyperlink to the created Word Doc in the body of the email, but I'm having issues setting it up - all help welcome! See original code below (minus email addresses) - thanks!

Sub Create_CAR_Folder()

'Set Word Objects
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdRng As Word.Range 'Need this to replace text outside of main body (e.g. header/footers)
    
'Set email objects
    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

'Set up Outlook
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
'Define location paths
    Dim FromPath As String
    Dim FromForm As String
    Dim ToPath As String
    Dim Hype As String
    
'Define initials to email addresses
    Dim emailValue As String
    Dim iniCell As Range
    
'Get path for template and new CAR
    FromPath = [CARLISTS!E2]
    FromForm = [CARLISTS!F2]
    ToPath = [CARLISTS!G2] & "\" & ActiveCell
    
'Copies all files and subfolders from FromPath to (ToPath & "/" & ActiveCell).
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    objFSO.copyFolder FromPath, ToPath, False

'Opens CAR template
    Set wdApp = CreateObject("word.application")
    wdApp.Visible = True
    Set wdDoc = wdApp.Documents.Open(ToPath & "\" & FromForm)

'Finds text <CAR NUMBER> and replaces with ActiveCell
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<CAR NUMBER>"
            .Replacement.Text = ActiveCell
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng

'Finds text <PRODUCT> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<PRODUCT>"
            .Replacement.Text = ActiveCell.Offset(0, 1).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <SOURCE> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<SOURCE>"
            .Replacement.Text = ActiveCell.Offset(0, 2).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
   
'Finds text <RAISED BY> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<RAISED BY>"
            .Replacement.Text = ActiveCell.Offset(0, 3).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <DD/MM/YY> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<DD/MM/YY>"
            .Replacement.Text = Format(ActiveCell.Offset(0, 4).Value, "dd/mm/yy")
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng

'Finds text <DEPT> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<DEPT>"
            .Replacement.Text = ActiveCell.Offset(0, 5).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <LEAD> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<LEAD>"
            .Replacement.Text = ActiveCell.Offset(0, 6).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <SONUM> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<SONUM>"
            .Replacement.Text = ActiveCell.Offset(0, 7).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <COMPANY> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<COMPANY>"
            .Replacement.Text = ActiveCell.Offset(0, 8).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <SUMMARY> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<SUMMARY>"
            .Replacement.Text = ActiveCell.Offset(0, 9).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <TERM> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<TERM>"
            .Replacement.Text = ActiveCell.Offset(0, 11).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
   
'Finds text <SDATE> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<SDATE>"
            .Replacement.Text = ActiveCell.Offset(0, 12).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <CDATE> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<CDATE>"
            .Replacement.Text = ActiveCell.Offset(0, 13).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Finds text <CADATE> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<CADATE>"
            .Replacement.Text = ActiveCell.Offset(0, 15).Value
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
  
'Finds text <LOG ENTRY> and replaces
    For Each wdRng In wdDoc.StoryRanges
        With wdRng.Find
            .Text = "<LOG ENTRY>"
            .Replacement.Text = "CAR created and submitted for approval."
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Next wdRng
    
'Save new CAR form
    wdDoc.SaveAs (ToPath & "\" & ActiveCell)

'Delete left over CAR template
    Kill (ToPath & "\" & FromForm)

    Set wdApp = Nothing: Set wdDoc = Nothing: Set wdRng = Nothing

'Finds email addresses from initials dropdown selections
    If ActiveCell Is Nothing Then
        MsgBox ("No cell is active")
    ElseIf ActiveCell.Value = vbNullString Then
        MsgBox ("Active cell is empty")
    Else
        Set iniCell = Worksheets(6).Range("A:A").Find(ActiveCell.Offset(0, 3).Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            If iniCell Is Nothing Then
                MsgBox ("Couldn't find a match")
            Else
                emailValue = iniCell.Offset(0, 1)
            End If
    End If

'Create email in Outlook
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

strbody = "Hello," & vbNewLine & vbNewLine & _
          ActiveCell & " has been created and is awaiting approval." & vbNewLine & vbNewLine & _
          "SUMMARY - " & ActiveCell.Offset(0, 9).Value & vbNewLine & vbNewLine & _
          "**********THIS EMAIL HAS BEEN AUTOMATICALLY GENERATED, PLEASE DO NOT RESPOND**********"

'Sets email addresses
On Error Resume Next
With OutMail
    .To = ""
    .CC = emailValue
    .BCC = ""
    .Subject = ActiveCell.Value
    .Body = strbody
    'You can add a file like this
    '.Attachments.Add ("C:\test.txt")
    .Send   'or use .Display
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

'Creation confirmation
MsgBox ActiveCell.Value & vbNewLine & _
"CREATED"

End Sub

 

[Micron]

perhaps if you modify this with block to use your own variable values. I don't have your referenced values so I created my own similar ones (e.g. strToPath)

With objMail
     .To = "[EMAIL]recipient@example.com[/EMAIL]"
     .Subject = "This is the subject"
     'Set the HTML body of the email.
     strBody = "A message goes here. <P><a href =" & """" & strToPath & strActiveCell & """" & ">Click Here for file.</a></P>"
     .HTMLBody = "<html><body>" & strBody & "</body></html>"
     .Display 'Display the email before sending it.
End With