在邮件正文中插入文本，超链接和表格

Question

我正在尝试在邮件正文中插入文本，超链接和表格。

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

此代码从链接的Excel工作表中检索数据并发送邮件。

要求是：

从链接的Excel工作表中检索To，CC，Body，Subject和签名数据。

  

预期结果：

     

请注意这是预期的格式。

预期的邮件正文包含超链接和表格。

注意：我需要从Excel中获取值，因为表中的值会不断变化。

Answer 1

请试试这个

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