vba 从 Excel 内容格式化电子邮件正文
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/28868877/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Formatting email body from Excel contents
提问by Manivannan KG
I have a worksheet with given data,
我有一个包含给定数据的工作表，
I need to email the data using Microsoft Outlook in the required format for a specific date.
我需要使用 Microsoft Outlook 以特定日期所需的格式通过电子邮件发送数据。
Say the date is 05 Jan 2015.
假设日期是 2015 年 1 月 5 日。
This is how the email should look,
这就是电子邮件的外观，
The code is written in the modules of the Excel 2007 workbook,
代码写在 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
回答by Ralph
If you want to create nicely formatted Outlook emails then you need to generate emails with formatting. Pure text-based-emails are evidently not sufficient and hence you must be looking for HTML formatted emails. If that's the case you probably aim to dynamically create HTML code with your VBA to mimic the nice visual representation of Excel.
如果您想创建格式良好的 Outlook 电子邮件，那么您需要生成带有格式的电子邮件。纯粹的基于文本的电子邮件显然是不够的，因此您必须寻找 HTML 格式的电子邮件。如果是这种情况，您的目标可能是使用 VBA 动态创建 HTML 代码，以模仿 Excel 的良好视觉表示。
Under the following link http://www.quackit.com/html/online-html-editor/you'll find an online HTML editor which allows you to prepare a nicely formatted email and then shows you the HTML code which is necessary to get this formatting. Afterwards you just need to set in VBA the email body to this HTML code using
在以下链接http://www.quackit.com/html/online-html-editor/ 下，您将找到一个在线 HTML 编辑器，它允许您准备格式良好的电子邮件，然后向您显示 HTML 代码，这是必要的得到这个格式。之后，您只需要在 VBA 中使用以下方法将电子邮件正文设置为此 HTML 代码
.HTMLBody = "your HTML code here"
instead of
代替
.Body = "pure text email without formatting"
If that is not sufficient and you want to copy / paste parts of your Excel into that email then you'll have to copy parts of your Excel, save them as a picture, and then add the picture to your email (once again using HTML). If this is what you want then you'll find the solution here: Using VBA Code how to export excel worksheets as image in Excel 2003?
如果这还不够，并且您想将部分 Excel 复制/粘贴到该电子邮件中，那么您必须复制部分 Excel，将它们另存为图片，然后将图片添加到您的电子邮件中（再次使用 HTML ）。如果这是您想要的，那么您将在此处找到解决方案： 使用 VBA 代码如何在 Excel 2003 中将 excel 工作表导出为图像？
回答by Manivannan KG
Here is the answer for that serves the purpose. The html body is build using string builder concept and the email is formed as required(Altered the sub of email from the post). This is working fine.
这是达到目的的答案。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> - </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
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> - </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
Recipients adress is dynamically retrieved from a range.
收件人地址是从一个范围内动态检索的。
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
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
