根据 Excel 内容格式化电子邮件正文

Question

我有一个包含给定数据的工作表，

我需要使用 Microsoft Outlook 以特定日期所需的格式通过电子邮件发送数据。

假设日期是 2015 年 1 月 5 日。

电子邮件应该是这样的，

代码写在Excel2007工作簿的模块中，

Public Function FormatEmail(Sourceworksheet As Worksheet, Recipients As Range, CoBDate As Date)

    Dim OutApp As Object
    Dim OutMail As Object
    Dim rows As Range

    On Error GoTo FormatEmail_Error

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    For Each rows In Recipients.Cells.SpecialCells(xlCellTypeConstants)

        If rows.value Like "?*@?*.?*" Then

            Set OutMail = OutApp.CreateItem(0)

            On Error Resume Next
            With OutMail
                .To = rows.value
                .Subject = "Reminder"
                .Body = "Hi All, " & vbNewLine & _
                         vbNewLine
                .display
            End With
            On Error GoTo 0

            Set OutMail = Nothing

        End If

    Next rows

    On Error GoTo 0
    Exit Function

FormatEmail_Error:

    Set OutApp = Nothing
    Application.ScreenUpdating = True
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FormatEmail of Module modOutlook"

End Function

Answer 1

如果您想创建格式良好的 Outlook 电子邮件，则需要生成具有格式的电子邮件。纯基于文本的电子邮件显然是不够的，因此您必须寻找 HTML 格式的电子邮件。如果是这种情况，您可能打算使用 VBA 动态创建 HTML 代码，以模仿 Excel.

的漂亮视觉表示

在下面的 link http://www.quackit.com/html/online-html-editor/ 下，您会找到一个在线 HTML 编辑器，它允许您准备格式良好的电子邮件，然后向您显示 HTML 代码这是获得这种格式所必需的。之后，您只需要使用

在 VBA 中将电子邮件正文设置为此 HTML 代码

.HTMLBody = "your HTML code here"

而不是

.Body = "pure text email without formatting"

如果这还不够，并且您想将 Excel 的部分内容复制/粘贴到该电子邮件中，那么您必须复制 Excel 的部分内容，将它们另存为图片，然后将图片添加到您的电子邮件中（再次使用 HTML）。如果这是你想要的，那么你会在这里找到解决方案： Using VBA Code how to export excel worksheets as image in Excel 2003?

Answer 2

这是符合目的的答案。 html 主体是使用字符串生成器概念构建的，电子邮件是根据需要形成的（更改了 post 中电子邮件的子部分）。这工作正常。

Public Function FormatEmail(Sourceworksheet As Worksheet, CoBDate As Date, FinalRatioLCR As Variant, FinalRatioAUD As Variant)

Dim OutApp As Object
Dim OutMail As Object
Dim eMsg As String

Dim ToRecipients As String

   On Error GoTo FormatEmail_Error

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

Dim Matrix2_1, Matrix2_2, Matrix2_3, Matrix3_1 As String
Dim FinanceAllCurrency, AllCurrencyT1, AllCurrencyT0, AllCurrencyAUD As Double

'FinanceAllCurrency = FinalRatioLCR
AllCurrencyT1 = 10.12
AllCurrencyT0 = 20.154
'AllCurrencyAUD = FinalRatioAUD
Matrix2_1 = "<td>" & FinalRatioLCR & "</td>"
Matrix2_2 = "<td>" & AllCurrencyT1 & "</td>"
Matrix2_3 = "<td>" & AllCurrencyT0 & "</td>"
Matrix3_1 = "<td>" & FinalRatioAUD & "</td>"

eMsg = "<head><style>table, th, td {border: 1px solid black; border-collapse:" & _
        "collapse;}</style></head><body>" & _
        "<table style=""width:50%""><tr>" & _
        "<th bgcolor=""#D8D8D8"">LCR</th><th bgcolor=""#D8D8D8"">Finance</th>" & _
         "<th bgcolor=""#D8D8D8"">Desk T+1</th><th bgcolor=""#D8D8D8"">Desk T+0</th></tr><tr>" & _
        "<td>All Currency</td>" & Matrix2_1 & Matrix2_2 & _
         Matrix2_3 & _
        "</tr><tr><td>AUD Only</td>" & Matrix3_1 & "<td>-</td>" & _
        "<td> &nbsp; &nbsp;  -  &nbsp;</td></tr></Table></body>"


ToRecipients = GetToRecipients

   Set OutMail = OutApp.CreateItem(0)
   
  
      With OutMail
                .To = ToRecipients
                .Subject = " Report -" & CoBDate
                .HTMLBody = "Hi All, " & "<br></br><br></br><br></br><br></br>" & _
                           eMsg
                .display
                
       End With
       
     On Error GoTo 0
     
     Set OutMail = Nothing

   On Error GoTo 0
   Exit Function

FormatEmail_Error:

    Set OutApp = Nothing
    Application.ScreenUpdating = True
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure FormatEmail of Module modOutlook"

End Function

收件人地址是从范围内动态检索的。

Private Function GetToRecipients() As String
Dim rngRows As Range
Dim returnName As String

For Each rngRows In shMapping.Range(MAPPING_EMAIL_RECIPIENTS).rows

If Len(returnName) = 0 Then
    returnName = rngRows.Cells(, 2).value2
ElseIf Len(rngRows.Cells(, 2).value2) > 0 Or rngRows.Cells(, 2).value2 Like "?*@?*.?*" Then
    returnName = returnName & ";" & rngRows.Cells(, 2).value2
End If

Next
GetToRecipients = returnName
End Function

根据 Excel 内容格式化电子邮件正文

Formatting email body from Excel contents

excel

vba

excel-2007