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

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片收件人，CC，身体，主题和签名数据。

预期的结果：

请注意，这是预期的格式。

预期的邮件正文中包含两个超链接和一张桌子。

注意：我需要从Excel中获取值，因为表中的值不断变化。要插入邮件内容到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