Question

我继承了带有VBA模块的数据库，该模块将数据表插入到Outlook电子邮件中。我想更改它，以便将相同数据的Excel工作表附加到电子邮件，而不是在电子邮件正文中插入表格。我不确定如何更改代码来做到这一点。

有人可以提供帮助吗？

代码如下：

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 tDCMEmailList")
    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'>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
    '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 = "xxxx"
        .Display
        '.Send
    End With

    rst2.MoveNext

'Loop

Clean_Up:
    rst.Close
    rst2.Close

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


End Sub

Answer 1

由于看起来您不想使用代码的表编辑部分，因此这可能满足您的需求。

在您的With objMail部分中，可以执行以下操作（更改原点和文件名）：

sOrigin = "C:\Users\Desktop\"
sFilename = "MyExcelSheet.xlsx"
.Attachments.Add (sOrigin & sFilename)

尚不清楚您的特定需求是什么，但这足以将Excel Sheet附加到电子邮件中。

注意：我强烈建议您删除与创建输出工作表相关的部分代码，以实现最终的期望目标。

Answer 2

因此，将结果作为附件发送实际上比在电子邮件中以表格形式发送要容易得多，只要您有一个保存的查询，其中包含需要发送的数据。

基本上，您可以使用Docmd.SendObject函数来发送保存的查询。但是，如前所述，它无法指定SendOnBehalfOf属性。看下面的代码：

Sub DCMEmailReviewVBA()
    ' assuming you have a saved query called qData
    ' that contains SQL like the following:
    '   select SELECT * 
    '   FROM tEmailData 
    '   where DCM_email=(select top 1 DCM_Email from tDCMEmailList)
    '   order by Cardholder, Card_Type asc

    Dim strTO as string

    ' there are better ways to do this, but this will quickly 
    ' get us what we want
    strTO = Dlookup("DCM_Email", "tDCMEmailList")

    ' the only thing this doesn't handle is the SendOnBehalfOfName
    ' if this is necessary to your process, you might want to stick with @Jiggles32
    docmd.SendObject _
            objecttype:=acSendQuery, _
            objectname:="qData", _
            outputformat:=acFormatXLSX , _
            to:=strTO, _
            cc:="", _
            bcc:=gDCMEmailBCC, _
            subject:=gDCMEmailSubject, _
            messagetext:="anything you want to put in your email message", _
            editmessage:=true
End Sub

如何将生成的HTML表转换为Excel工作表以通过电子邮件发送？

2 个答案: