how to add hyperlink into the body of an email via VBA? [Archive]

Ray707

04-07-2021, 08:06 AM

Hello,

I have a code that sends out emails to stakeholders attaching an excel file. I want to include a URL in the emails to direct stakeholders to one of our policies on our intranet. Ideally it would show the link as a text such as 'here' and not the file path e.g. 'the policy can be found on the intranet here'. I have tried to find a way of doing this but have been unsuccessful, can anyone help please? :thumb

Here is the code:

Sub ClientUnder()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
'indicates whether action is shown on scree (like excel pop up)
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copys the ActiveSheet to a new workbook
Sheet7.Copy
Set Destwb = ActiveWorkbook

'Determines the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsx": FileFormatNum = 51
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With

' 'Changes all cells in the worksheet to values
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False

'Saves the new workbook, Mails it then Deletes it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sheet7.Name & " " & Sourcewb.Name

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
'use for new line, put text inbetween and & _ @ the end as it indicates that the command isnt finished
.to = Sheet7.Range("M4")
.CC = Sheet93.Range("R1")
.BCC = Sheet93.Range("R2")
.Subject = Sheet7.Range("A5") & " " & Sheet7.Range("A7") & " " & Sheet7.Range("A6")
.htmlBody = Sheet93.Range("A6").Value & " " & Sheet7.Range("A8").Value & ", " & " " & " " & _
Sheet93.Range("A8").Value & " " & Sheet7.Range("G13") & " " & " " & _
Sheet93.Range("A10").Value & " " & " " & _
Sheet93.Range("A12").Value & " " & " " & _
" Included in Budget" & " " & " " & _
Sheet93.Range("A16").Value & " " & _
Sheet93.Range("A17").Value & " " & _
Sheet93.Range("A18").Value & " " & _
Sheet93.Range("A19").Value & " " & _
Sheet93.Range("A20").Value & " " & _
Sheet93.Range("A21").Value & " " & _
Sheet93.Range("A22").Value & " " & " " & _
" Not Included in Budget" & " " & " " & _
Sheet93.Range("A26").Value & " " & _
Sheet93.Range("A27").Value & " " & " " & _
Sheet93.Range("A29").Value & " " & " " & _
Sheet93.Range("A31").Value & " " & _
Sheet93.Range("A32").Value & " " & _
Sheet93.Range("A33").Value & " " & _
Sheet93.Range("A34").Value & " " & _
Sheet93.Range("A35").Value & " " & _
Sheet93.Range("A36").Value & " " & _
Sheet93.Range("A37").Value & " " & " " & Sheet93.Range("A39").Value & " " & " " & _
Sheet93.Range("A41").Value & " " & Sheet93.Range("A42").Value & " " & " " & " " & Sheet93.Range("A45").Value & " " & Sheet93.Range("A46").Value & _
eMsg
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

Kenneth Hobs

04-07-2021, 06:48 PM

Depends on if it is local/network file or a web link. For the former:

Sub email()
Dim body As String
With CreateObject("Outlook.Application").CreateItem(0)
.To = "ken@gmail.com"
.Subject = "Test Click Here (Notepad.exe)"
.Display
body = .HTMLBody
.HTMLBody = "Body " & vbCrLf & body & "" & "<a href=""File://c:/Windows/Notepad.exe"">Click Here</a>"
.Display
'.Send
End With
End Sub
If the latter, put the url between the double quotes.

Ray707

04-08-2021, 12:21 AM

Kenneth thank you, that worked! But there are two problems; firstly, at the top of the email it now says the word 'body' and secondly, the 'click here' link is at the bottom of the email.

Let me show you where I put your suggestions in my code (see bold):

Sub ClientUnder()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object
'indicates whether action is shown on scree (like excel pop up)
With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copys the ActiveSheet to a new workbook
Sheet7.Copy
Set Destwb = ActiveWorkbook

'Determines the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2016
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsx": FileFormatNum = 51
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End With

' 'Changes all cells in the worksheet to values
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False

'Saves the new workbook, Mails it then Deletes it
TempFilePath = Environ$("temp") & "\"
TempFileName = Sheet7.Name & " " & Sourcewb.Name

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
'use for new line, put text inbetween and & _ @ the end as it indicates that the command isnt finished
.to = Sheet7.Range("M4")
.CC = Sheet93.Range("R1")
.BCC = Sheet93.Range("R2")
.Subject = Sheet7.Range("A5") & " " & Sheet7.Range("A7") & " " & Sheet7.Range("A6")
.HTMLBody = Sheet93.Range("A6").Value & " " & Sheet7.Range("A8").Value & ", " & " " & " " & _
Sheet93.Range("A8").Value & " " & Sheet7.Range("G13") & " " & " " & _
Sheet93.Range("A10").Value & " " & " " & _
Sheet93.Range("A12").Value & " " & " " & _
" Included in Budget" & " " & " " & _
Sheet93.Range("A16").Value & " " & _
Sheet93.Range("A17").Value & " " & _
Sheet93.Range("A18").Value & " " & _
Sheet93.Range("A19").Value & " " & _
Sheet93.Range("A20").Value & " " & _
Sheet93.Range("A21").Value & " " & _
Sheet93.Range("A22").Value & " " & " " & _
" Not Included in Budget" & " " & " " & _
Sheet93.Range("A26").Value & " " & _
Sheet93.Range("A27").Value & " " & " " & _
Sheet93.Range("A29").Value & " " & " " & _
Sheet93.Range("A31").Value & " " & _
Sheet93.Range("A32").Value & " " & _
Sheet93.Range("A33").Value & " " & _
Sheet93.Range("A34").Value & " " & _
Sheet93.Range("A35").Value & " " & _
Sheet93.Range("A36").Value & " " & _
Sheet93.Range("A37").Value & " " & " " & Sheet93.Range("A39").Value & " " & Sheet93.Range("A40").Value & " " & " " & _
Sheet93.Range("A41").Value & " " & Sheet93.Range("A42").Value & " " & " " & " " & Sheet93.Range("A45").Value & " " & Sheet93.Range("A46").Value & _
eMsg
body = .HTMLBody
.HTMLBody = "Body " & vbCrLf & body & "" & "<a href=""www.test.com"">Click Here</a>"
.Attachments.Add Destwb.FullName
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
.Close savechanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

The email looks like this now (notice the word 'body' is right at the beginning and 'click here' is at the end of the email):

Body Hi John,

Please find attached the spend file.

Can you please review the spend and let me know if any of the costs should be moved.

The Expenses Guidelines and Policy can be found on the intranet in the link below:
2020 Expenses Guidelines.pdf

Thanks,
Joe

Joe Bloggs,
Management Accountant
Click Here

I want the 'click here' to be where it says '2020 Expenses Guidelines.pdf' and do not want the word 'body' at the beginning of the email...

Kenneth Hobs

04-08-2021, 05:30 AM

Concatenate however you like to build your string for .htmlBody.

#2 was just a simple example. The "Body" was just an example string. Body variable contains your signature if you insert it by default. The last part is the html tag syntax string for a hyperlink. Put it anywhere in your many concatenated string.

Your string could be made more concise. Rather than " use " ". I would use a 2nd With to avoid the use of Sheet93 so much. You don't even need a sheet reference if it is the ActiveSheet. Rather than spanning multiple lines, I would build the string earlier in the macro and just do this sort of thing:
Dim s as string
s="Hello "
s=s & "World!"
'....
.htmlBody=s

I can show you more string building tips later if that interest you.