通過循環查詢和將其格式化為VBA Access中的列來編寫多行電子郵件

Question

我有一個訪問查詢，旨在循環瀏覽並將其內容寫入Outlook電子郵件的電子郵件正文。 下面的代碼可以完成這項工作，但是，如果有很多行，那么看起來就不太好看，變得非常繁忙。

我想添加一些格式化規則，這些規則將每個變量對齊到一個“列”中，或者將每個變量設置為固定長度，以使管道（“ |”）對齊（當然，使變量固定長度可能表示從左側填充一些空格。

或者，我可以嘗試使用HTML或其他方式解決此問題？ 盡管我對此沒有經驗，但是如果這是可行的方法，那么任何建議都將不勝感激。

Public Sub Test()

On Error GoTo Error_Handler

Dim strbody, DateStamp
strbody = ""
DateStamp = Format(Date, "Medium Date")

Dim MyDB As DAO.Database
Dim Tem As DAO.Recordset
Set MyDB = CurrentDb()
Set Tem = MyDB.OpenRecordset("TestQuery", dbOpenForwardOnly)
With Tem
    Do While Not .EOF
        strbody = strbody + (CStr(![Num]) + " | " + CStr(Format(![TDate], "Medium Date")) + " | " + CStr(Format(![VDate], "Medium Date")) + " | " + CStr(Format(![QTY], "Standard")) + " | " + ![Name] & vbNewLine)
        .MoveNext
    Loop
End With
Tem.Close
Set Tem = Nothing

Dim OutApp As Object
Dim OutMail As Object

Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem

Set objOutlook = CreateObject("Outlook.application")
Set objEmail = objOutlook.CreateItem(olMailItem)

With objEmail
    .To = "test@abc.com"
    .subject = "Test" & " " & DateStamp
    .Body = strbody
    .Display
End With

Exit_Here:
    Set objOutlook = Nothing
    Exit Sub

Error_Handler:
    MsgBox Err & ": " & Err.Description
    Resume Exit_Here

End Sub

當前，電子郵件中的輸出看起來像這樣：

1234 | 22-Aug-18 | 23-Aug-18 | 1,000.00 | testname 123 
5678 | 21-Aug-18 | 22-Aug-18 | 50,000.00 | second testname of different length

除缺少列名外，行越多，得到的信息越多。

再次感謝您的幫助。 謝謝。

Answer 1

我用HTML郵件來做。

我有一個HTML郵件模板另存為.oft文件，並創建如下郵件項目：

Dim oItem As Outlook.MailItem
Set oItem = oOutlook.CreateItemFromTemplate(TemplatePath)

郵件模板包含$TableGoesHere$之類的變量，在創建郵件時將其替換為變量數據，例如

Set Tem = MyDB.OpenRecordset("TestQuery", dbOpenForwardOnly)
strTbl = OutlookHtmlTableFromRS(Tem)

oItem.HtmlBody = Replace(oItem.HtmlBody, "$TableGoesHere$", strTbl)

具有以下功能：

' Create HTML table from a recordset, with all columns except those in <sExcl>
' Returns HTML string to insert into HTML mail
Public Function OutlookHtmlTableFromRS(RS As Recordset, Optional sExcl As String = "") As String

    Dim fld As DAO.Field
    Dim S As String

    ' Table heading row
    S = "<table cellpadding='5' style='text-align:left; border: 1px solid gray; border-collapse:collapse; font-family:Calibri, Helvetica, sans-serif; font-size:11pt;'>" & _
        "<tr style='padding:5px;border: 1px solid gray;'>"

    For Each fld In RS.Fields
        If InStr(sExcl, fld.Name) = 0 Then
            S = S & "<th style='border: 1px solid gray;'>" & fld.Name & "</th>"
        End If
    Next fld
    S = S & "</tr>"

    ' Data rows
    Do While Not RS.EOF
        S = S & "<tr style='padding:5px;'>"

        For Each fld In RS.Fields
            If InStr(sExcl, fld.Name) = 0 Then
                S = S & "<td style='border: 1px solid gray;'>" & fld.Value & "</td>"
            End If
        Next fld

        S = S & "</tr>"
        RS.MoveNext
    Loop

    S = S & "</table>"

    RS.Close

    OutlookHtmlTableFromRS = S

End Function

Answer 2

是的，HTML是最好的方法！ :)使用HTML，您可以在Outlook中創建表並進行格式設置！ HTML非常容易。 對於任何所需的格式，只需將其谷歌搜索即可。 例如，如果您希望某些數據右對齊，則可以使用谷歌“ html table right align”。 有很多有用的HTML網站。

下面的VBA代碼是我用來將Access查詢的內容放入Outlook電子郵件正文中的代碼。

它看起來很長，但可以正常工作，這是將查詢或表復制到電子郵件中的最佳方法。

我喜歡這個！ 我的電子郵件看起來真的很好！

Private Sub btnEmail_Click()
'This will open an email in your Outlook and compose it for you. You review and click send.
'This macro requires the reference "Microsoft Outlook 16.0 Object Library" to be enabled.

Dim f As Long, c As Long  
Dim sTable As String
Dim rs As DAO.Recordset
Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olRecip As Recipient
Dim Recipients As Recipients
Dim qField(1 To 4)  'array


''Table Header
qField(1) = "Group Number"
qField(2) = "Group Name"
qField(3) = "PTD"
qField(4) = "Term Date"
sTable = "<table border=0 cellspacing=0 style='padding:0in 5.5pt 0in 5.5pt'><tbody>"
sTable = sTable & "<tr bgcolor=""#70ad47""><font color=""white""><b><td>Group#</td>"  'white font, bold, green fill
sTable = sTable & "<td>Group Name</td>"
sTable = sTable & "<td>PTD</td>"
sTable = sTable & "<td>Term Date</td></b></font></tr>"

''Rows
Set rs = CurrentDb.OpenRecordset("TestQuery")
Do Until rs.EOF
    c = c + 1   'counter for the every other row light green
    If c Mod 2 = 0 Then   'every other row light green
        sTable = sTable & "<tr style=""background: #e2efd9"">"
    Else
        sTable = sTable & "<tr>"   'open row
    End If

    For f = 1 To 4        'cells
        sTable = sTable & "<td>" & rs.Fields(qField(f)) & "</td>"
    Next
    sTable = sTable & "</tr>"   'close row
    rs.MoveNext
Loop
sTable = sTable & "</tbody></table>"   'close table
rs.Close
Set rs = Nothing

''Compose Email
Set olApp = CreateObject("Outlook.Application")
Set olMsg = olApp.CreateItem(olMailItem)
olMsg.To = "test@abc.com"
For Each olRecip In olMsg.Recipients
  olRecip.Resolve
Next
olMsg.Subject = "Test " & Format(Date, "Medium Date")
olMsg.Display   'This must go before the .HTMLBody line b/c that is the only way to capture the existing default signature.
olMsg.HTMLBody = "<Body><div>Hello,<br>" & _
  "Please see report below.<br><br>" & sTable & olMsg.HTMLBody