Email Body Hyperlink

[dodonohoe]

Hi everyone,

I am creating an email automatically and populating the text with sentences taken from an Excel spreadsheet. That is working fine. I am struggling to figure out how to insert a hyperlink. I have tried a lot of different ways but can't get it to work.

Here is my effort here. The Hyperlink address is just coming up as text. It is the .html body at the end that I need help with (where I am trying to put a hyperlink to www.google.com ).


Sub AutoEmailTest()




Application.ScreenUpdating = False


Dim OApp As Object, OMail As Object, signature As String
Set OApp = CreateObject("Outlook.Application")




Dim FileNameZip As String
Dim Attached As String
Attached = Range("D2")
FileNameZip = Attached



Dim FirstName As String
Dim SirName As String
Dim EmailX As String
Dim rowno As Integer
Dim EndRow As Integer
Dim SenderX As String

rowno = Range("E2")
EndRow = Range("F2")



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Email Text

Dim SubjectX As String
Dim SubjectY As String

Dim SignoffX As String
Dim Line1 As String
Dim Line2 As String
Dim Line3 As String
Dim Line4 As String
Dim Line5 As String
Dim Line6 As String
Dim Line7 As String
Dim Line8 As String
Dim Line9 As String
Dim Line10 As String




2

Do Until rowno = EndRow + 1




If Cells(rowno, 1) <> "" Then

FirstName = Cells(rowno, 1)
SirName = Cells(rowno, 2)
EmailX = Cells(rowno, 3)
SenderX = Range("G2")



rowno = rowno + 1

GoTo 1

End If


Loop


1





''''''''''''''''''''''''''''''''''''''''''''''''''
'Personalise Subject

SubjectX = Range("J2")

If Range("H2") = "Yes" Then

SubjectX = FirstName & ", " & SubjectX

Else

SubjectX = SubjectX

End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''

SignoffX = Range("J3")


Line1 = Range("J4")

If Range("H4") = "Yes" Then

Line1 = Line1 & " " & FirstName & ","

Else

Line1 = Line1

End If

Line2 = Range("J5")
Line3 = Range("J6")
Line4 = Range("J7")
Line5 = Range("J8")
Line6 = Range("J9")
Line7 = Range("J10")
Line8 = Range("J11")
Line9 = Range("J12")
Line10 = Range("J13")

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''




Set OMail = OApp.CreateItem(0)



With OMail
.Display
End With

signature = OMail.HTMLbody
With OMail
.To = EmailX
.Subject = SubjectX

'.HTMLbody = "Ciara is cool" & vbNewLine & signature

Dim SubmitLink As String

SubmitLink = "www.google.com"

'get last row

Dim lastRow As Integer
lastRow = Cells(Rows.Count, "J").End(xlUp).Row


Dim FilePathX As String

'if there are 10 lines in the e-mail '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


If lastRow = 13 Then


.HTMLbody = "<p style='font-family:calibri;font-size:15;color:navy'>" & Line1 & "<br>" & "<br>" _
& Line2 _
& "<br>" & "<br>" _
& Line3 _
& "<br>" & "<br>" _
& Line4 _
& "<br>" & "<br>" _
& Line5 _
& "<br>" & "<br>" _
& Line6 _
& "<br>" & "<br>" _
& Line7 _
& "<br>" & "<br>" _
& Line8 _
& "<br>" & "<br>" _
& Line9 _
& "<br>" & "<br>" _
& Line10 _
& "<br>" & "<br>" _
& "< ahref=""http://www.google.com/"">" _
& "Kind Regards," _
& "<br>" & "<br>" _
& SenderX & signature

GoTo 3

End If




3

If FileNameZip <> "" Then

.Attachments.Add FileNameZip

End If


.Save
.UnRead = True
.Close 1


End With




If rowno = EndRow + 1 Then

Set OMail = Nothing
Set OApp = Nothing

Application.ScreenUpdating = True





End

End If

GoTo 2








End Sub




Cheers,

Des

[gmayor]

There are a number of issues here. First of all it looks as though you are running the code from Excel rather than Outlook. You cannot start Outlook from Excel as you have done in the code and then edit the body of the message in code as it doesn't work. You need to start Outlook using the code at http://www.rondebruin.nl/win/s1/outlook/openclose.htm which will open Outlook correctly - The explanations are linked from that page.

You can then call that function from Excel VBA to start Outlook and use it to create a message as follows.

I am not even going to try and decipher your Excel code, but you can use the Excel data to provide the various texts used in place of the fixed texts shown here. The code will insert the signature associated with the mail account.

Use vba paragraph breaks in your text strings and not HTML tags. e.g.


strText1 = strText1 & vbCr & vbCr _
& Range("J5") _
& vbCr & vbCr _
& Range("J6") _
& vbCr & vbCr _
& Range("J7") _
& vbCr & vbCr _
& Range("J8") _
& vbCr & vbCr _
& Range("J9") _
& vbCr & vbCr _
& Range("J10") & vbCr & vbCr


Option Explicit

Sub AddHyperlink()
Dim olApp As Object
Dim olEmail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim oRng As Object
Dim oLink As Object
Dim strLink As String
Dim strLinkText As String
Dim strText1 As String
Dim strText2 As String

'The texts before and after the link
strText1 = "If you wish to download or view our latest catalogue, please simply follow this link: " & vbCr & vbCr
strText2 = vbCr & vbCr & "Should you wish to review or enquire about any of our products, please do not hesitate to get in touch."

strLink = "http://www.gmayor.com" ' the link address
strLinkText = "Click here for Graham Mayor's Web Site " ' the link display text

On Error Resume Next
Set olApp = OutlookApp() 'Call the function to start Outlook
Set olEmail = olApp.CreateItem(0) 'mail item
With olEmail
.To = "Someone@somewhere.com"
.Subject = "The message subject"
.BodyFormat = 2 'html
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
oRng.Text = strText1
oRng.collapse 0
Set oLink = wdDoc.Hyperlinks.Add(Anchor:=oRng, _
Address:=strLink, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=strLinkText)
Set oRng = oLink.Range
oRng.collapse 0
oRng.Text = strText2
.Display
End With
lbl_Exit:
Exit Sub
End Sub

[dodonohoe]

Hi Graham,

I followed your instructions and that worked absolutely perfectly so thanks very much. For anyone that is stuck, just follow the links from Graham above.

Cheers,

Des