Copy a link as hyperlink in email body

[annadinesh]

Dear Team

The RED highlighted Link i want this should copy as hyperlnk in Email Body so that the receiver can click on link and get the location

my Code:

Private Sub CommandButton3_Click()
If ActiveSheet.Name = "Sheet2" Then

If IsEmpty(Worksheets("Sheet2").Range("E3")) Then
Cancel = True
MsgBox ("Email ID Blank"), vbDefaultButton1, "E Mail"

Else
Dim Outlook As Object
Dim email As Object
Dim xInspect As Object
Dim pageEditor As Object
Dim assunto As String, para As String
Dim myRange As Excel.Range

Set Outlook = CreateObject("Outlook.application")
Set email = Outlook.CreateItem(0)

With email
.Subject = "Service Due Reminder of your Hyundai Car"
.To = Range("E3").Value
.Display

Set xInspect = email.GetInspector
Set pageEditor = xInspect.WordEditor

pageEditor.Range.Characters(1).Select
With pageEditor.Application.Selection

.Collapse 1 ' 1 = wdCollapseStart
.InsertAfter "Dear Hyundai Customer," & vbCrLf & vbCrLf & _
"here's the info:" & vbCrLf & vbCrLf & _
"Click Link for Location

Google Maps

Find local businesses, view maps and get driving directions in Google Maps.

goo.gl

" & vbCrLf & vbCrLf & vbCrLf

.Collapse 0 ' 0 = wdCollapseEnd
For Each myRange In Sheets("Sheet2") _
.Range("C4:H7").Areas
myRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

'.PasteAndFormat Type:=13 ' 13 = wdChartPicture
.PasteSpecial DataType:=4 ' 4 = wdPasteBitmap
.Collapse 0

Next myRange


End With
.Display

Set pageEditor = Nothing
Set xInspect = Nothing

End With
Sheets("Sheet1").Activate
Set email = Nothing
Set Outlook = Nothing

End If
End If
End Sub

 

[ranman256]

Const Q = """"
With oMail
    .To = "W.E.Coyote@acme.com"
    .Subject = "my subject
    .HTMLBody ="<a href=" & Q & "https://www.w3schools.com/" & Q & ">Visit W3Schools.com!</a>"
end with