在Outlook邮件中格式化两个数据表

时间:2018-02-28 15:49:44

标签: ms-access access-vba outlook-vba

我正在尝试将两个数据表放入电子邮件中。

我有VBA代码包含一个表。第二个表的数据位于tEmailData中,该数据与tdistinct_DCMs表以及DCM_Email字段相关。

我已经为电子邮件提供了当前的VBA,并为第二个表提供了VBA格式。

如何在第一个表和短段文本后添加该表?

Option Compare Database
Option Explicit

Public Sub DCMEmailReviewVBA()

    Dim rst As DAO.Recordset
    Dim olApp As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim rst2 As DAO.Recordset
    Dim strTableBeg As String
    Dim strTableBody As String
    Dim strTableEnd As String
    Dim strFntNormal As String
    Dim strTableHeader As String
    Dim strFntEnd As String

    Set rst2 = CurrentDb.OpenRecordset("select distinct DCM_email from tDistinct_DCMs")
    rst2.MoveFirst

    'Create e-mail item
    Set olApp = Outlook.Application
    Set objMail = olApp.CreateItem(olMailItem)

    'Do Until rst2.EOF

    Set olApp = Outlook.Application
    Set objMail = olApp.CreateItem(olMailItem)

    'Define format for output
    strTableBeg = "<table border=1 cellpadding=3 cellspacing=0>"
    strTableEnd = "</table>"
    strTableHeader = "<font size=3 face=" & Chr(34) & "Calibri" & Chr(34) & "><b>" & _
                        "<tr bgcolor=lightBlue>" & _
                            "<TD align = 'left'>Status</TD>" & _
                            "<TD align = 'left'>First Name</TD>" & _
                            "<TD align = 'left'>Last Name</TD>" & _
                            "<TD align = 'left'>UIN</TD>" & _
                            "</tr></b></font>"
    strFntNormal = "<font color=black face=" & Chr(34) & "Calibri" & Chr(34) & " size=3>"
    strFntEnd = "</font>"

    Set rst = CurrentDb.OpenRecordset("SELECT * FROM tFinalDCM_EmailList where DCM_Email='" & rst2!DCM_Email & "' Order by [Cardholder_UIN] asc")
    rst.MoveFirst



    'Build HTML Output for the DataSet
    strTableBody = strTableBeg & strFntNormal & strTableHeader



    Do Until rst.EOF
        strTableBody = strTableBody & _
                        "<tr>" & _
                            "<TD align = 'left'>" & rst![Action] & "</TD>" & _
                            "<TD align = 'left'>" & rst![Cardholder First Name] & "</TD>" & _
                            "<TD align = 'left'>" & rst![Cardholder Last Name] & "</TD>" & _
                            "<TD align = 'left'>" & rst![Cardholder_UIN] & "</TD>" & _
                            "</tr>"

        rst.MoveNext
    Loop
    'rst.MoveFirst

    strTableBody = strTableBody & strFntEnd & strTableEnd


    'rst.Close

    'Set rst2 = CurrentDb.OpenRecordset("select distinct ch_email from t_TCard_CH_Email")
    'rst2.MoveFirst



Call CaptureDCMBodyText

    With objMail
        'Set body format to HTML
        .To = rst2!DCM_Email
        .BCC = gDCMEmailBCC
        .Subject = gDCMEmailSubject
        .BodyFormat = olFormatHTML

        .HTMLBody = .HTMLBody & gDCMBodyText

        .HTMLBody = .HTMLBody & "<HTML><BODY>" & strFntNormal & strTableBody & " </BODY></HTML>"

        .HTMLBody = .HTMLBody & gDCMBodySig

        .SentOnBehalfOfName = "..."
        .Display
        '.Send
    End With

    rst2.MoveNext

'Loop

Clean_Up:
    rst.Close
    rst2.Close

    Set rst = Nothing
    Set rst2 = Nothing
    'Set dbs = Nothing


End Sub

Function td(strIn As String) As String
    td = "<TD nowrap>" & strIn & "</TD>"
End Function

所需第二张桌子的VBA:

strTableBeg = "<table border=1 cellpadding=3 cellspacing=0>"
    strTableEnd = "</table>"
    strTableHeader = "<font size=3 face=" & Chr(34) & "Calibri" & Chr(34) & "><b>" & _
                        "<tr bgcolor=lightblue>" & _
                            "<TD align = 'left'>Card Type</TD>" & _
                            "<TD align = 'left'>Cardholder</TD>" & _
                            "<TD align = 'left'>ER or Doc No</TD>" & _
                            "<TD align = 'center'>Trans Date</TD>" & _
                            "<TD align = 'left'>Vendor</TD>" & _
                            "<TD align = 'right'>Trans Amt</TD>" & _
                            "<TD align = 'left'>TEM Activity Name or P-Card Log No</TD>" & _
                            "<TD align = 'left'>Status</TD>" & _
                            "<TD align = 'right'>Aging</TD>" & _
                           "</tr></b></font>"

    strFntNormal = "<font color=black face=" & Chr(34) & "Calibri" & Chr(34) & " size=3>"
    strFntEnd = "</font>"

    Set rst = CurrentDb.OpenRecordset("SELECT * FROM tEmailData where DCM_email='" & rst2!DCM_Email & "' Order by Cardholder, Card_Type asc")
    rst.MoveFirst



    'Build HTML Output for the DataSet
    strTableBody = strTableBeg & strFntNormal & strTableHeader



    Do Until rst.EOF
        strTableBody = strTableBody & _
                        "<tr>" & _
                            "<TD align = 'left'>" & rst!Card_Type & "</TD>" & _
                            "<TD align = 'left'>" & rst!Cardholder & "</TD>" & _
                            "<TD align = 'left'>" & rst!ERNumber_DocNumber & "</TD>" & _
                            "<TD align = 'center'>" & rst!Trans_Date & "</TD>" & _
                            "<TD align = 'left'>" & rst!Vendor & "</TD>" & _
                            "<TD align = 'right'>" & Format(rst!Trans_Amt, "currency") & "</TD>" & _
                            "<TD align = 'left'>" & rst!ACTIVITY_Log_No & "</TD>" & _
                            "<TD align = 'left'>" & rst!Status & "</TD>" & _
                            "<TD align = 'right'>" & rst!Aging & "</TD>" & _
                        "</tr>"

        rst.MoveNext
    Loop

1 个答案:

答案 0 :(得分:0)

我还没看过你的表,但构建Html文档的代码有问题。

.HTMLBody = .HTMLBody & gDCMBodyText

.HTMLBody = .HTMLBody & "<HTML><BODY>" & strFntNormal & strTableBody & " </BODY></HTML>"

.HTMLBody = .HTMLBody & gDCMBodySig

我找不到gDCMBodyText,之前的陈述没有在HtmlBody中放置任何内容,那你为什么要连接它呢?

<HTML>必须先到,</HTML>必须到最后。

您在提问中提到要包含文字,但我不清楚在哪里。

我建议如下:

Dim Table1 As string    ' First table: <table> ... </table>
Dim Table2 As string    ' Second table: <table> ... </table>
Dim TextPre As string   ' Text to come before first table
Dim TextMid As string   ' Text to come between tables
Dim TextPost As string  ' Text to come after second table

为上述字符串分配适当的值,然后

.HtmlBody = "<html><body>" & vbLf & _
            TextPre & vbLf & _
            Table1 & vbLf & _
            TextMid & vbLf & _
            TextPost & vbLf & _ 
            "</body></html>"

第2部分

我会将此视为四个不同的问题:(1)格式表1正确,(2)格式表2正确,(3)正确组合表格和(4)创建HtmlBody。

对于1,2和3等问题,我使用下面的例程。宏HtmlDoc将Head和Body元素组合成一个简单的Html文档。这没什么大不了的,但确实让生活变得更简单。宏PutTextFileUtf8输出一个字符串作为UTF-8文件。注1:UTF-8是Html文件的默认编码,允许文件中的任何Unicode字符。注意2:此宏需要引用&#34; Microsoft ActiveX数据对象n.n库&#34;。

我会使用这些例程来(1)检查表1是否正确创建,(2)检查表2是否正确创建,以及(3)检查表是否正确组合。如果任何文件不是我想要的,我可以查看文本文件。查看格式错误的电子邮件的Html正文更加困难。

Function HtmlDoc(ByVal Head As String, ByVal Body As String)

  ' Returns a simple Hhml document created from Head and Body

  HtmlDoc = "<!DOCTYPE html>" & vbLf & "<html>" & vbLf
  If Head <> "" Then
    HtmlDoc = HtmlDoc & "<head>" & vbLf & Head & vbLf & "</head>" & vbLf
  End If
  HtmlDoc = HtmlDoc & "<body>" & vbLf & Body & vbLf & "</body>" & vbLf
  HtmlDoc = HtmlDoc & "</html>"

End Function
Public Sub PutTextFileUtf8(ByVal PathFileName As String, ByVal FileBody As String)

  ' Outputs FileBody as a text file (UTF-8 encoding without leading BOM)
  ' named PathFileName

  ' Needs reference to "Microsoft ActiveX Data Objects n.n Library"
  ' Addition to original code says version 2.5. Tested with version 6.1.

  '  1Nov16  Copied from http://stackoverflow.com/a/4461250/973283
  '          but replaced literals with parameters.
  ' 15Aug17  Discovered routine was adding an LF to the end of the file.
  '          Added code to discard that LF.

  ' References: http://stackoverflow.com/a/4461250/973283
  '             https://www.w3schools.com/asp/ado_ref_stream.asp

  Dim BinaryStream As Object
  Dim UTFStream As Object

  Set UTFStream = CreateObject("adodb.stream")

  UTFStream.Type = adTypeText
  UTFStream.Mode = adModeReadWrite
  UTFStream.Charset = "UTF-8"
  ' The LineSeparator will be added to the end of FileBody. It is possible
  ' to select a different value for LineSeparator but I can find nothing to
  ' suggest it is possible to not add anything to the end of FileBody
  UTFStream.LineSeparator = adLF
  UTFStream.Open
  UTFStream.WriteText FileBody, adWriteLine

  UTFStream.Position = 3 'skip BOM

  Set BinaryStream = CreateObject("adodb.stream")
  BinaryStream.Type = adTypeBinary
  BinaryStream.Mode = adModeReadWrite
  BinaryStream.Open

  UTFStream.CopyTo BinaryStream

  ' Originally I planned to use "CopyTo Dest, NumChars" to not copy the last
  ' byte.  However, NumChars is described as an integer whereas Position is
  ' described as Long. I was concerned that by "integer" they mean 16 bits.
  BinaryStream.Position = BinaryStream.Position - 1
  BinaryStream.SetEOS

  UTFStream.Flush
  UTFStream.Close
  Set UTFStream = Nothing

  BinaryStream.SaveToFile PathFileName, adSaveCreateOverWrite
  BinaryStream.Flush
  BinaryStream.Close
  Set BinaryStream = Nothing

End Sub

第3部分

<TD align = 'left'>Card Type</TD>中,align = 'left'是默认设置,因此可以省略。

更重要的是,align属性在Html 4中被折旧,我在Html 5中找不到它。建议使用CSS。

我建议你输出一个像这样的HEAD元素:

  <head>
    <style>
      table {border-collapse:collapse;}
      td {border-style:solid; border-width:1px; border-color:#BFBFBF;}
       tr.bc-lb {background-color:lightblue;}
       td.ha-c {text-align:center;}
      td.ha-r {text-align:right;}
    </style>
  <head>

和TR和TD这样的元素:

<tr class= “bg-lb”>
<td>Card Type</td>
<td class=“ha-c“>Trans Date</td>"
<td class=“ha-r“>Trans Amt</td>"

table {border-collapse:collapse;}指定CSS折叠表模型。仅当您具有单元格边框时,才会显示折叠和单独模型之间的差异。随着崩溃,边界接触但是它们之间存在一个小的间隙。

td {border-style:solid; border-width:1px; border-color:#BFBFBF;}指定每个单元格都有一个深灰色的实心边框,我更喜欢黑色。

tr.bc-lb {background-color:lightblue;}允许我通过在TR开始标记中包含class= “bg-lb”将行的背景颜色设置为浅蓝色。

我认为其他款式及其用途可以从上述信息中推断出来。

<强>摘要

无法访问您的系统,我无法测试您的代码的任何重写版本。我希望我已经给你足够的信息来修改你自己的代码。