如何在Excel VBA中创建表格发送电子邮件？

Question

我每周从Excel发送时间表，我想将数据转换为表格，其中周数是每个合并列的顶部，而日期和日期则是每列的顶部。

我不知道如何将邮件正文消息重写为表格。该代码可能有很多不必要的字符串，但是可以工作。我想补充一点，我对VBA还是很陌生，或者对此完全没有任何编码，并且仍然可以学习。

Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

    Dim olMail As Outlook.MailItem
    Set olMail = olApp.CreateItem(olMailItem)

    olMail.To = what_address
    olMail.Subject = subject_line
    olMail.Body = mail_body
    olMail.Send

End Sub
Sub SendSchedules()

row_number = 2

Do
DoEvents
    row_number = row_number + 1
    Dim mail_body_message As String
    Dim full_name As String
    Dim replace_Monday As String
    Dim replace_Tuesday As String
    Dim replace_Wednesday As String
    Dim replace_Thursday As String
    Dim replace_Friday As String
    Dim replace_Saturday As String
    Dim replace_Sunday As String


    mail_body_message = ActiveSheet.Range("J1") & vbNewLine & ActiveSheet.Range("C1") & " " & ActiveSheet.Range("C2") & vbNewLine & ActiveSheet.Range("D1") & " " & ActiveSheet.Range("D2") & vbNewLine & ActiveSheet.Range("E1") & " " & ActiveSheet.Range("E2") & vbNewLine & ActiveSheet.Range("F1") & " " & ActiveSheet.Range("F2") & vbNewLine & ActiveSheet.Range("G1") & " " & ActiveSheet.Range("G2") & vbNewLine & ActiveSheet.Range("H1") & " " & ActiveSheet.Range("H2") & vbNewLine & ActiveSheet.Range("I1") & " " & ActiveSheet.Range("I2")
    full_name = ActiveSheet.Range("B" & row_number)
    mon_day = ActiveSheet.Range("C" & row_number)
    tues_day = ActiveSheet.Range("D" & row_number)
    wednes_day = ActiveSheet.Range("E" & row_number)
    thurs_day = ActiveSheet.Range("F" & row_number)
    fri_day = ActiveSheet.Range("G" & row_number)
    satur_day = ActiveSheet.Range("H" & row_number)
    sun_day = ActiveSheet.Range("I" & row_number)
    week_number = ActiveSheet.Range("K2")


    mail_body_message = Replace(mail_body_message, "replace_name_here", full_name)
    mail_body_message = Replace(mail_body_message, "replace_week_number", week_number)
    mail_body_message = Replace(mail_body_message, "replace_Monday", mon_day)
    mail_body_message = Replace(mail_body_message, "replace_Tuesday", tues_day)
    mail_body_message = Replace(mail_body_message, "replace_Wednesday", wednes_day)
    mail_body_message = Replace(mail_body_message, "replace_Thursday", thurs_day)
    mail_body_message = Replace(mail_body_message, "replace_Friday", fri_day)
    mail_body_message = Replace(mail_body_message, "replace_Saturday", satur_day)
    mail_body_message = Replace(mail_body_message, "replace_Sunday", sun_day)
        MsgBox mail_body_message
    Call SendEmail(ActiveSheet.Range("A" & row_number), "Schedule Week 1", mail_body_message)
Loop Until row_number = 12

End Sub

这段代码没什么问题，但是现在我想获取这些信息并从中创建一个表。尽管我担心我需要重新编写整个内容，但不确定如何。

Answer 1

在excel中有很多创建表的方法，但是我只能想到两种通过电子邮件发送表的好方法。

您可以使用VBA设置临时的excel spreedsheet，以正确的格式格式化表格。此时，您可以使用VBA简单复制整个内容并将其粘贴到HTML电子邮件中。

或者，使用VBA，您可以简单地使用HTML生成整个文本正文，然后将整个HTML字符串发送到您的电子邮件正文中。

我已经使用过HTML路由很多次了，它可以节省大量时间，并且更加有用。

编辑：这是一个使用HTML的示例，它很粗糙，我在早期就写了它。请注意，这是根据我的用例进行修改的。因此，您可能需要对其进行一些调整。

Sub Dealer_Email(Sheet As String, Name As Variant, Recipient As Variant, Subject As Variant, _
Mon as Variant, Tues as Variant, Wednesday as Variant, Thurs as Variant, _
Friday as Variant, Optional Copy As String, Optional Blind_Copy As String, _
    Optional Attach As String)
' Sheet = the Sheet name in which you wish to pull data from (this was designed for multiple sheets with identical layouts.
'Name = the Name in which will be entered into the generated email
'Recipient = the email address
'Subject = the subject line
'Optional Copy = If you wish to 'cc' someone on the email
'Optional Blind_copy = adds someone to 'bcc' on the email
'Optional attachment = You can define a file to be attached to the email 
' Parts of this function came from https://www.rondebruin.nl/
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Dim x, y As Variant
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(Sheet)
strbody = "<table>"
    strbody = strbody & _
        "<tr>" & _
            "<td> | </td>" & _
            "<td>" & Mon & "</td>" & _
            "<td> | </td>" & _
            "<td>" & Tues & "</td>" & _
            "<td> | </td>" & _
            "<td>" & Wednes & "</td>" & _
            "<td> | </td>" & _
            "<td>" & Thurs & "</td>" & _
            "<td> | </td>" & _
            "<td>" & Fri & "</td>" & _
            "<td> | </td>" & _
            "<td>" & Sat & "</td>" & _
            "<td> | </td>" & _
            "<td>" & Sun & "</td>" & _
            "<td> | </td>" & "</tr></table>"

strbody = "<font>Good Day " & Name & ",<br><br>" & _
          "Insert Message Here...<br>" & _
          strbody & _
          "<br>" & _
          "If you have any questions, feel free to contact me.</font>"

          2
On Error Resume Next

With OutMail
    .Display
    .To = Recipient
    .CC = Copy
    .BCC = Blind_Copy
    .Subject = Subject
    .htmlbody = strbody & .htmlbody
    .Attachment = Attach
End With

OutMail.Display

On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing

结束子

请注意，这确实需要Microsoft Outlook才能运行。该代码的一部分确实来自https://www.rondebruin.nl/。

您可以轻松地添加一个循环，并根据需要对html图表中的每一行重复此操作。

编辑（第二时间）：

Sub SendSchedules()
Dim row_number As Integer

row_number = 2

Do
DoEvents
    row_number = row_number + 1
    Dim mail_body_message As String
    Dim full_name As String
    Dim replace_Monday As String
    Dim replace_Tuesday As String
    Dim replace_Wednesday As String
    Dim replace_Thursday As String
    Dim replace_Friday As String
    Dim replace_Saturday As String
    Dim replace_Sunday As String

    full_name = ActiveSheet.Range("B" & row_number).Value
    mon_day = ActiveSheet.Range("C" & row_number).Value
    tues_day = ActiveSheet.Range("D" & row_number).Value
    wednes_day = ActiveSheet.Range("E" & row_number).Value
    thurs_day = ActiveSheet.Range("F" & row_number).Value
    fri_day = ActiveSheet.Range("G" & row_number).Value
    satur_day = ActiveSheet.Range("H" & row_number).Value
    sun_day = ActiveSheet.Range("I" & row_number).Value
    week_number = ActiveSheet.Range("K2").Value


strbody = "<table>"
    mail_body_message = strbody & _
        "<tr>" & _
            "<td> Full Name: </td>" & _
            "<td>" & full_name & "</td></tr>" & _
            "<tr><td>Week Number: </td>" & _
            "<td>" & week_number & "</td></tr>" & _
            "<tr><td>Monday: </td>" & _
            "<td>" & mon_day & "</td></tr>" & _
            "<tr><td>Tuesday: </td>" & _
            "<td>" & tues_day & "</td></tr>" & _
            "<tr><td>Wednesday: </td>" & _
            "<td>" & wednes_day & "</td></tr>" & _
            "<tr><td>Thursday: </td>" & _
            "<td>" & thurs_day & "</td></tr>" & _
            "<tr><td>Friday: </td>" & _
            "<td>" & fri_day & "</td></tr>" & _
            "<tr><td>Saturday: </td>" & _
            "<td>" & satur_day & "</td></tr>" & _
            "<tr><td>Sunday: </td>" & _
            "<td>" & sun_day & "</td></tr>" & _
            "</table>"

        MsgBox mail_body_message
Loop Until row_number = 12

您需要从以下位置更改另一行代码：

    olMail.Body = mail_body

至以下。

    olMail.htmlbody = mail_body & .htmlbody

我希望这会有所帮助。