Question

我有一些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

我想要做的是使用HTML格式化strMessage = "...TEXT..."，例如将其设置为粗体。

我尝试过以下操作：

Set MyMessage = MyOutlook.CreateItem(0)
With MyMessage
   .HTMLBody = .HTMLBody & "<br><B>WEEKLY REPPORT:</B><br>" _
            & "<img src='cid:DashboardFile.jpg'" & "width='814' height='33'><br>" _
            & "<br>Best Regards,<br>Ed</font></span>"
End With

我查看了各种网站，包括：http://vba-useful.blogspot.co.uk/2014/01/send-html-email-with-embedded-images.html但我无法让它发挥作用。

我该怎么做？

Answer 1

首先，不要混合.Body和.HTMLBody。选一个。正如你想要格式化＆amp;一张照片，.HTMLBody就是你所需要的。

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

第三：注意无效的HTML，例如关闭从未打开过的字体和span标记。也可以使用 代替MyMessage.HTMLBody = "" & strMessage & " WEEKLY REPORT: " _ & "<img src='cid:DashboardFile.jpg' width='814' height='33' /> " _ & " Best Regards, Ed"（过时）。

第四：完全设置HTMLBody，不要追加它。

我不知道你的img是否会显示，但无论如何都是第二步。话虽这么说，试试这个：

chr(13)

编辑：如果您希望在strMessage中保留换行符，请先将 替换为{{1}}。

VBA如何将HTML放入通过Access模块发送的电子邮件中

1 个答案:

VBA如何将HTML放入通过Access模块​​发送的电子邮件中

1 个答案:

VBA如何将HTML放入通过Access模块发送的电子邮件中