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

Question

我有一个具有给定数据的工作表， “在此处输入图像描述”

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

说日期是2015年1月5日。 “在此处输入图像描述”

这是电子邮件的外观， “在此处输入图像描述”

代码是在Excel 2007工作簿的模块中编写的，

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的美观外观。

在以下链接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主体是使用字符串构建器概念构建的，并且电子邮件是根据需要形成的（更改了帖子中电子邮件的子内容）。这很好。

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内容格式化电子邮件正文

问题描述投票：3回答：2

2个回答

最新问题

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

问题描述 投票：3回答：2

2个回答

最新问题

问题描述投票：3回答：2