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

使用VBA发送带附件的群发电子邮件

1 个答案: