VBA如何在通过访问模块发送的电子邮件中放置HTML

我收到了一些VBA代码，可以通过MS Access发送带有附件的电子邮件：

Sub Email_Send()


Dim strTo As String
Dim strCc As String
Dim strFrom As String
Dim strSubject As String
Dim strMessage As String
Dim intNrAttch As Integer
Dim strAttachments As String
Dim strAttachments2 As String
Dim Contact_Name As String
Dim EMAIL_Address As String
Dim CC_Address As String
Dim Column1 As ADODB.Recordset
Dim cnnDB As ADODB.Connection
Dim Area As String
Dim Connection As String
Dim BasePath As String
Dim Region As String
Dim Column2 As String
Dim UPC As String
Dim Name As String
Dim FirstName As String
Dim Title As String
Dim Surname As String
Dim Bold As String
Dim a As String

BasePath = "MY PATH"

Set cnnDB = New ADODB.Connection
With cnnDB
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "MY CONNECTION STRING"
.Open
End With

Set rstRst = New ADODB.Recordset
rstRst .Source = "SELECT [column1], [column2], [column3]" & _
        "FROM table1"

    rstRst.Open , cnnDB
    rstRst.MoveFirst


    Do While Not rstRst .EOF
        Column1 = rstRst.Fields("Column1")
        Column2 = rstRst.Fields("Column2")
        Column3_Address = rstRst.Fields("Column3")


        Dim Greeting As String
        If Time >= #12:00:00 PM# Then
            Greeting = "Afternoon,"
        Else
            Greeting = "Morning,"
        End If

        Dim CurrentMonth As String
        CurrentMonth = MonthName(Month(Date))

        strMessage = "Good" & Greeting & Chr(13)
        strMessage = strMessage & Chr(13)
        strMessage = strMessage & "...TEXT..." & Chr(13)
        strMessage = strMessage & Chr(13)
        strMessage = strMessage & "...TEXT..." & Chr(13)
        strMessage = strMessage & "" & Chr(13)
        strMessage = strMessage & "...TEXT..." & Chr(13)
        strMessage = strMessage & "" & Chr(13)
        strMessage = strMessage & "...TEXT..." & Chr(13)
        strMessage = strMessage & "" & Chr(13)
        strMessage = strMessage & "...TEXT..." & Chr(13)
        strMessage = strMessage & "...TEXT..." & Chr(13)
        strMessage = strMessage & Chr(13)
        strMessage = strMessage & "...TEXT..." & Chr(13)
        strMessage = strMessage & "...TEXT..." & Chr(13)

        strTo = EMAIL_Address
        'strCc = CC_Address
        strSubject = "Information: ...TEXT..." & Column2 & "...TEXT..."
        intNrAttch = 1

            strAttachments = BasePath & Column1 & "file.xls"

        Call SendMessageTo(strTo, strSubject, strMessage, intNrAttch,     strAttachments)

        rstRST.MoveNext
    Loop

MsgBox "sent"

NowExit:

End Sub

Public Function SendMessageTo(strTo As String, strSubject As String,     strMessage As String, intNrAttch As Integer, strAttachments As String) As     Boolean

Const Nr = 9
Dim MyOutlook As Object
Dim MyMessage As Object
Dim objNameSpace
Dim strFiles(Nr) As String
Dim strPromt As String
Dim i As Integer, intLen As Integer
Dim intStart, intPos As Integer


On Error GoTo Error_Handler

SendMessageTo = False
Set MyOutlook = CreateObject("Outlook.Application")
Set MyMessage = MyOutlook.CreateItem(0)

If strTo = "" Then
    strPromt = "You need to specify the e-mail address to wich you want to send this e-mail"
    MsgBox strPromt, vbInformation, "Send Message To... ?"
    Exit Function
End If

If intNrAttch > Nr + 1 Then
    strPromt = "You can only add up to " & Nr + 1 & " attachments. If you want     to add more you will need to change the array size"
    MsgBox strPromt, vbCritical, "Number of Attachments"
End If

intStart = 1
intLen = 0
If strAttachments <> "" Then
    For i = 0 To intNrAttch - 1
        If i < intNrAttch - 1 Then
            intLen = InStr(intStart, strAttachments, ";") - intStart + 1
            strFiles(i) = Trim(Mid(strAttachments, intStart, intLen - 1))
            intStart = intStart + intLen
    Else
            strFiles(i) = Trim(Mid(strAttachments, intStart,             Len(strAttachments) - intStart + 1))
    End If
    Next i
End If

intPos = Len(strMessage) + 1
With MyMessage
.To = strTo
.Subject = strSubject
.Body = strMessage
   strAttachments = "1"
    If     strAttachments <> "" Then
    For i = 0 To intNrAttch - 1
        .Attachments.Add strFiles(i), 1, intPos
    Next i
End If
.Send
End With


Set MyMessage = Nothing
Set MyOutlook = Nothing
SendMessageTo = True

Error_Handler_Exit:
Exit Function

Error_Handler:
MsgBox Err.Number & " : " & Err.Description, vbCritical, Error
Resume Error_Handler_Exit

End Function

我看过各种网站，包括：但我无法让它工作

---

我该怎么做呢？

首先，不要将.Body和.HTMLBody混合在一起。挑一个。当你想要格式化图片时，.HTMLBody就是你所需要的

第二：不要混合使用大写和小写HTML标记。使用较低的

第三：注意无效的HTML，比如关闭从未打开过的字体和span标记。也可以使用

而不是

（过时）

第四：完全设置HTMLBody，不要附加到它

我不知道你的img是否会显示出来，但这只是第二步。 也就是说，试试这个：

MyMessage.HTMLBody = "<p class=MsoNormal>" & strMessage & "<br /><b>WEEKLY REPORT:</b><br />" _
            & "<img src='cid:DashboardFile.jpg' width='814' height='33' /><br />" _
            & "<br />Best Regards,<br />Ed</p>"

MyMessage.HTMLBody=“
”&strMessage&“
每周报告：
”_
&“
”_
&“向您致意，
Ed
”

---

编辑：如果您希望保留strMessage中的换行符，只需先将

chr（13）

替换为

。

在运行时连接src和width属性时，src和width属性之间没有空格，因此您应该添加一个。此外，您还需要将图像附加到电子邮件，看起来您在尝试时删除了该部分。

MyMessage.HTMLBody = "<p class=MsoNormal>" & strMessage & "<br /><b>WEEKLY REPORT:</b><br />" _
            & "<img src='cid:DashboardFile.jpg' width='814' height='33' /><br />" _
            & "<br />Best Regards,<br />Ed</p>"