Insert text, hyperlink and table in the mail body

Question

I am trying to insert text, hyperlink and table in the mail body.

Sub Sendmail()

    Dim olItem As Outlook.MailItem
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSht As Excel.Worksheet
    Dim sPath As String
    Dim iRow As Long
    Dim strRFIitems As String
    Dim Signature As String

    sPath = "**"

    '   // Excel    
    Set xlApp = CreateObject("Excel.Application")

    '   // Workbook
    Set xlBook = xlApp.Workbooks.Open(sPath)

    '   // Sheet
    Set xlSht = xlBook.Sheets("Sheet1")

    '   // Create e-mail Item
    Set olItem = Application.CreateItem(olMailItem)
    trRFIitems = xlSht.Range("E2")
    Signature = xlSht.Range("F2")

    With olItem
        .To = Join(xlApp.Transpose(xlSht.Range("A2", xlSht.Range("A9999").End(xlUp))), ";")    
        .CC = Join(xlApp.Transpose(xlSht.Range("B2", xlSht.Range("B9999").End(xlUp))), ";")
        .Subject = xlSht.Range("C2")
        .Body = xlSht.Range("D2") & Signature
        .Attachments.Add (strRFIitems)
        .Display
    End With

    '   // Close
    xlBook.Close SaveChanges:=True

    '   // Quit
    xlApp.Quit

    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSht = Nothing
    Set olItem = Nothing

End Sub

This code retrieves the data from the linked Excel sheet and sends a mail.

The requirement is:

Retrieve the To, CC, Body, Subject and signature data from the linked Excel sheet.

The expected result:

Please note this is the expected format.

The expected mail body contains both hyperlink and a table.

Note: I need to get values from Excel because the values in the table keep changing.

Answer 1

please try this

Sub testEmail()

    ' these constants are necessary when using "late binding"
    ' determined by using "early binding" during initial development

    Const wdTextureNone = 0
    Const wdColorAutomatic = &HFF000000              ' -16777216
    Const wdWord9TableBehavior = 1
    Const wdAlignParagraphCenter = 1
    Const wdAutoFitContent = 1
    Const wdAutoFitWindow = 2
    Const wdAutoFitFixed = 0

    Dim outMail As Outlook.MailItem
    Set outMail = Application.CreateItem(olMailItem) ' 0
    outMail.Display (False)                          ' modeless

'   Dim wd As word.Documents                         ' early binding ... requires reference to "microsoft word object library"
    Dim wd As Object                                 ' late binding  ... no reference required
    Set wd = outMail.GetInspector.WordEditor

    wd.Paragraphs.Space2                             ' double spaced
    wd.Paragraphs.SpaceAfter = 3
    wd.Paragraphs.SpaceBefore = 1

    wd.Range.InsertAfter "Hi Team!" & vbCrLf
    wd.Range.InsertAfter "Please update the portal with the latest information." & vbCrLf
    wd.Range.InsertAfter "The portal link:" & vbCrLf

'   wd.Words(wd.Words.Count).Select                 ' debug

    wd.Hyperlinks.Add Anchor:=wd.Words(wd.Words.Count), _
            Address:="http://google.com", SubAddress:="", _
            ScreenTip:="this is a screen ttip", TextToDisplay:="link text to display"

    wd.Range.InsertAfter vbCrLf

'   wd.Words(wd.Words.Count).Select                 ' debug

    wd.Range.InsertAfter "The team details are mentioned below:" & vbCrLf

    wd.Tables.Add Range:=wd.Words(wd.Words.Count), NumRows:=3, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed  ' 1,0

'   Dim tabl As word.Table                           ' early binding ... requires reference to "microsoft word object library"
    Dim tabl As Object                               ' late binding  ... no reference required
    Set tabl = wd.Tables(1)


    tabl.Cell(1, 1).Range.Text = "Team"
    tabl.Cell(1, 2).Range.Text = "Head"

    tabl.Cell(2, 1).Range.Text = "litmus"
    tabl.Cell(2, 2).Range.Text = "Sam"

    tabl.Cell(3, 1).Range.Text = "sigma"
    tabl.Cell(3, 2).Range.Text = "tony"

    wd.Range.InsertAfter vbCrLf & "regards" & vbCrLf

' --------------------------------------------------------------------
' configure the table
' --------------------------------------------------------------------

'    wd.Tables(1).Columns(1).Cells(1).Select         ' debug
'    wd.Tables(1).Columns(1).Cells(2).Select
'    wd.Tables(1).Columns(1).Cells(3).Select

    tabl.Style = "Table Grid"
    tabl.ApplyStyleHeadingRows = True
    tabl.ApplyStyleLastRow = False
    tabl.ApplyStyleFirstColumn = True
    tabl.ApplyStyleLastColumn = False
    tabl.ApplyStyleRowBands = True
    tabl.ApplyStyleColumnBands = False

    tabl.Shading.Texture = wdTextureNone                       ' 0
    tabl.Shading.ForegroundPatternColor = wdColorAutomatic     ' -16777216 (hex: &HFF000000)
    tabl.Shading.BackgroundPatternColor = wdColorAutomatic
    tabl.Rows(1).Shading.BackgroundPatternColor = RGB(200, 250, 200)  ' table header colour

'    tabl.Shading.BackgroundPatternColor = wdColorRed

'    tabl.Range.Select     ' debug

    tabl.Range.Paragraphs.Space1    ' single spaced
    tabl.Range.Paragraphs.SpaceAfter = 0
    tabl.Range.Paragraphs.SpaceBefore = 0


    tabl.Range.Font.Size = 14
    tabl.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter  ' 1

    tabl.Rows(1).Range.Font.Size = 18
    tabl.Rows(1).Range.Bold = True


'   tabl.AutoFitBehavior (wdAutoFitContent)  ' 1
'   tabl.AutoFitBehavior (wdAutoFitWindow)   ' 2
    tabl.AutoFitBehavior (wdAutoFitFixed)    ' 0
    tabl.Columns(1).Width = 100
    tabl.Columns(2).Width = 100

    Set tabl = Nothing
    Set wd = Nothing
    Set outMail = Nothing
End Sub