Question

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

enter image description here

我需要使用Micorosft outlook以特定日期所需的格式通过电子邮件发送数据（比如说日期是2015年1月5日）。请参阅下面的

enter image description here

这是电子邮件的外观，

enter image description here

我是业余开发人员，通过VBA格式化电子邮件。代码是在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

Stackoverflow拥有一批专家。热心帮助，并且非常感谢。提前谢谢。

此致

摩尼

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

VBA-从excel内容格式化电子邮件正文

2 个答案: