I am working on an Excel spreadsheet that is working just the way I want it to with one exception. I want to allow the email recipient to see the actual hyperlink and be able to open it from the email.
The below is the code I am currently using but I don’t know how (or where) to put the code you mentioned. How can I revise my code to include whatever it is I need to have to have the email show the actual hyperlink link so a person receiving the email can simply click on the link? With my current code, this is the email I get. My hyperlinks are in cell S.
Here is my code:
Sub Button1_Click()
Dim rngCell As Range
Dim Rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strBody As String
Dim EmailSubject As String
Dim SendToMail As String
Dim r As Long
Application.ScreenUpdating = False
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
Set OutApp = CreateObject("Outlook.Application")
Set Rng = Range("T5", Cells(Rows.Count, "T").End(xlUp))
For Each rngCell In Rng
r = rngCell.Row
If Range("J" & r).Value = "" And Range("K" & r).Value <> "" And Range("I" & r).Value <= Date Then
Range("J" & r).Value = Date
Set OutMail = OutApp.CreateItem(0)
strBody = "According to my records, your " & Range("A" & r) & Range("S" & r).Value & _
" contract is due for review. This contract expires " & Range("K" & r).Value & _
". It is important you review this contract ASAP and email me " & _
"with any changes that are made. If it is renewed or rolled over, please fill out the " & _
"Contract Cover Sheet which can be found in the Everyone folder " & _
"and send me the Contract Cover Sheet along with the new original contract."
SendToMail = Range("T" & r).Value
EmailSubject = Range("A" & r).Value
On Error Resume Next
With OutMail
.To = SendToMail
.CC = ""
.BCC = "email address removed for privacy reasons"
.Subject = EmailSubject
.Body = strBody
.Display ' You can use .Send
End With
End If
Next rngCell
Application.ScreenUpdating = True
End Sub