使用VBA发送包含附件的大量电子邮件

Question

我在使用附件发送大量电子邮件时使用了特别的代码。

Sub Mailout() 


Dim Source As Document, Maillist As Document, TempDoc As Document 
Dim Datarange As Range 
Dim i As Long, j As Long 
Dim bStarted As Boolean 
Dim oOutlookApp As Outlook.Application 
Dim oItem As Outlook.MailItem 
Dim mysubject As String, message As String, title As String 
Set Source = ActiveDocument 
' Check if Outlook is running. If it is not, start Outlook 
On Error Resume Next 
Set oOutlookApp = GetObject(, "Outlook.Application") 
If Err <> 0 Then 
Set oOutlookApp = CreateObject("Outlook.Application") 
bStarted = True 
End If 
' Open the catalog mailmerge document 
With Dialogs(wdDialogFileOpen) 
.Show 
End With 
Set Maillist = ActiveDocument 
' Show an input box asking the user for the subject to be inserted into the   email messages 
message = "Enter the subject to be used for each email message."  
' Set prompt. 
title = " Email Subject Input" ' Set title. 
' Display message, title 
mysubject = InputBox(message, title) 
' Iterate through the Sections of the Source document and the rows of the  catalog mailmerge document, 
' extracting the information to be included in each email. 
For j = 1 To Source.Sections.Count - 1 
Set oItem = oOutlookApp.CreateItem(olMailItem) 
With oItem 
    .Subject = mysubject 
    .Body = Source.Sections(j).Range.Text 
    Set Datarange = Maillist.Tables(1).Cell(j, 1).Range 
    Datarange.End = Datarange.End - 1 
    .To = Datarange 
    For i = 2 To Maillist.Tables(1).Columns.Count 
     Set Datarange = Maillist.Tables(1).Cell(j, i).Range 
     Datarange.End = Datarange.End - 1 
     .Attachments.Add Trim(Datarange.Text), olByValue, 1 
    Next i 
    .Send 
End With 
Set oItem = Nothing 
Next j 
Maillist.Close wdDoNotSaveChanges 
' Close Outlook if it was started by this macro. 
If bStarted Then 
oOutlookApp.Quit 
End If 
MsgBox Source.Sections.Count - 1 & " messages have been sent." 
'Clean up 
Set oOutlookApp = Nothing 

End Sub 

我能够发送附件，但电子邮件格式化消失。例如，粗体标题变成普通线，超链接消失并且变成正常文本短语。任何人都可以指出究竟哪里出了问题？

谢谢！ 困厄的工人。

Answer 1

尝试使用.HTMLBody代替.Body

With oItem 
    .Subject = mysubject 
    .HTMLBody = Source.Sections(j).Range.Text 'Change this line 
    Set Datarange = Maillist.Tables(1).Cell(j, 1).Range 
    Datarange.End = Datarange.End - 1 
    .To = Datarange 
    For i = 2 To Maillist.Tables(1).Columns.Count 
     Set Datarange = Maillist.Tables(1).Cell(j, i).Range 
     Datarange.End = Datarange.End - 1 
     .Attachments.Add Trim(Datarange.Text), olByValue, 1 
    Next i 
    .Send 
End With