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