應張老師的需求，修改制作了一個可以批量發送帶附件的電子郵件VBA。

目的：給N多人發送電子郵件，而不是抄送模式，并帶有對方的稱謂。

實現：

用到Word的郵件合并功能，以及調用Outlook發送郵件。不過VBA我不太懂，只能用現有的改，有點繁瑣。

步驟：

1.

Word建立一個表，第一列為表頭，下面為每個人的記錄，從第四列開始為附件列，需要加幾個附件，就添加幾個列，可以留空，像第五列一樣：

Name

Title

Email

Attachment

Xiao Ma

PhD.

e:\test.txt

Copper

Dr.

e:\test2.txt

Marry

Miss.

e:\test.txt

2. 保存該word文件。

3. 新建一個Word文檔，我用的是word2010版本，選擇郵件選項卡。

4. 選擇收件人，使用現有列表，打開之前編輯的word文件

5. 使用插入合并域功能，編輯郵件正文：

如：

Dear

<

><>

I’m mxio.

Good 2 c u at 9t.

Good

Luck!

mxio

2012.11.13

6. 點擊預覽結果，更新域

7. 啟動編輯宏功能，鍵盤按ALT+F11

8. 工具\引用添加 Microsoft Outlook 14.0 Object Library

9. 新建模塊添加如下代碼：

Sub eMailMergeWithAttachments()

Dim docSource As Document, docMaillist As Document

Dim rngDatarange As Range

Dim i As Long, j As Long

Dim lRecordCount As Long

Dim bStarted As Boolean

Dim oOutlookApp As Outlook.Application

Dim oItem As Outlook.MailItem

Dim oAccount As Outlook.Account

Dim sMySubject As String, sMessage As String, sTitle As

String

'將當前文檔設置為源文檔(主文檔)

Set docSource = ActiveDocument

'檢查Outlook是不是打開了。如果未打開的話，就打開新的Outlook

On

Error Resume Next

Set oOutlookApp = GetObject(, "Outlook.Application")

If

Err <> 0 Then

Set oOutlookApp = CreateObject("Outlook.Application")

bStarted = True

End If

'打開保存有客人的郵件地址和需要發送的附件的路徑的word文檔。

With Dialogs(wdDialogFileOpen)

.Show

End With

'將該文檔設置為客戶郵件(附件)列表文檔

Set docMaillist = ActiveDocument

'設置發送郵件的賬戶(賬戶必須已經在Outlook中設置好了)

'注意：如果你的Outlook版本低于2007，使用設置發送郵件的賬戶可能會導致錯誤，

'建議將下面的Set oAccount =

oOutlookApp.Session.Accounts.Item("someone@examplemail.com")語句刪除

Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")

'顯示一個輸入框，詢問并讓用戶輸入郵件主題

sMessage = "請為要發送的郵件輸入郵件主題。"

sTitle = "輸入郵件主題"

sMySubject = InputBox(sMessage, sTitle)

'循環查找源文檔中所有的節(每一節為一封郵件內容)，以及循環查找郵件列表文檔中所有的客戶信息，

'以便用于插入到生成的郵件中

'獲取需要發送的郵件數，并將當前節置為第一條記錄

lRecordCount

= docMaillist.Tables(1).Rows.Count

docSource.MailMerge.DataSource.ActiveRecord =

wdFirstRecord

'第一列為表頭，需跳過

For j = 2 To

lRecordCount

Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem

'注意：如果你的Outlook版本低于2007，使用設置發送郵件的賬戶可能會導致錯誤，

'建議將下面的.SendUsingAccount = oAccount語句刪除

.SendUsingAccount = oAccount

.Subject = sMySubject

'正文內容，節號1的文字

.Body = docSource.Sections(1).Range.Text

Set rngDatarange = docMaillist.Tables(1).Cell(j,

3).Range

rngDatarange.End = rngDatarange.End - 1

.To = rngDatarange

For i = 4 To docMaillist.Tables(1).Columns.Count

Set rngDatarange = docMaillist.Tables(1).Cell(j,

i).Range

rngDatarange.End = rngDatarange.End - 1

.Attachments.Add Trim(rngDatarange.Text), olByValue, 1

Next i

.Send

End With

Set oItem = Nothing

'Word郵件文檔下一節

docSource.MailMerge.DataSource.ActiveRecord =

wdNextRecord

Next j

docMaillist.Close wdDoNotSaveChanges

'如果Outlook是由該宏打開的，則關閉Outlook

If

bStarted Then

oOutlookApp.Quit

End If

MsgBox "共發送了 " & lRecordCount - 1 &

" 封郵件。"

'清空Outlook實例

Set oOutlookApp = Nothing

End Sub

10. 執行該代碼。

mxio

2012.11.13

________________________________2012.12.6_______________________________

實踐證明還是excel的好些，改了改：

Sub sendmail()

Dim xlApp

As New Excel.Application

Dim

oOutlookApp As Outlook.Application

Dim

docSource As Document

Dim colCount

As Long, rowCount As Long

Dim

lRecordCount As Long, endColNo As Long

Dim bStarted

As Boolean

Dim oItem

As Outlook.MailItem

Dim oAccount

As Outlook.Account

Dim

sMySubject As String, sMessage As String, sTitle As String,

sMailList As String

'將當前文檔設置為源文檔(主文檔)

Set

docSource = ActiveDocument

'獲取當前excel工作簿路徑

sMailList =

docSource.MailMerge.DataSource.Name

'檢查Outlook是不是打開了。如果未打開的話，就打開新的Outlook

On Error

Resume Next

Set

oOutlookApp = GetObject(, "Outlook.Application")

If Err

<> 0 Then

Set oOutlookApp = CreateObject("Outlook.Application")

bStarted = True

End If

'打開保存有客人的郵件地址和需要發送的附件的路徑的excel文檔。

Dim wb As

Excel.Workbook

Set wb =

xlApp.Workbooks.Open(sMailList)

xlApp.Visible = Flase

'設置發送郵件的賬戶(賬戶必須已經在Outlook中設置好了)

'注意：如果你的Outlook版本低于2007，使用設置發送郵件的賬戶可能會導致錯誤，

'建議將下面的Set oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")語句刪除

Set

oAccount = oOutlookApp.Session.Accounts.Item("someone@examplemail.com")

'顯示一個輸入框，詢問并讓用戶輸入郵件主題

sMessage

= "請為要發送的郵件輸入郵件主題。"

sTitle =

"輸入郵件主題"

'sMySubject = InputBox(sMessage, sTitle)

'免打擾模式設置郵件主題

sMySubject =

"test"

'循環查找源文檔中所有的節(每一節為一封郵件內容)，以及循環查找郵件列表文檔中所有的客戶信息，

'以便用于插入到生成的郵件中

'獲取需要發送的郵件數，列數，并將當前節置為第一條記錄

lRecordCount

= wb.Sheets("Sheet1").Cells(1, 1).CurrentRegion.Rows.Count

endColNo =

wb.Sheets("Sheet1").Cells(1, 1).CurrentRegion.Columns.Count

docSource.MailMerge.DataSource.ActiveRecord = wdFirstRecord

'第一列為表頭，需跳過

For rowCount

= 2 To lRecordCount

Set oItem = oOutlookApp.CreateItem(olMailItem)

With oItem

'注意：如果你的Outlook版本低于2007，使用設置發送郵件的賬戶可能會導致錯誤，

'建議將下面的.SendUsingAccount = oAccount語句刪除

.SendUsingAccount = oAccount

.Subject = sMySubject

'使用純文本格式，正文內容，節號1的文字

'.Body = docSource.Sections(1).Range.Text

'正文使用HTML代碼格式，可保留排版格式，用論壇上的文本編輯器可輕松獲取HTML代碼

.HTMLBody = docSource.Sections(1).Range.Text

'如果excel數據結構發生改變，那么請修改此次email地址所在列數，默認為4

.To = wb.Sheets("Sheet1").Cells(rowCount, 4)

'如果excel數據結構發生改變，那么請修改此次附件地址所在列數，默認為5

For colCount = 5 To endColNo

.Attachments.Add Trim(wb.Sheets("Sheet1").Cells(rowCount,

colCount))

Next colCount

'發送 or 僅顯示 or 保存草稿箱，重要郵件，推薦使用 .Display模式，確認后點擊發送即可

.Send

'.Display

'.Save

End With

Set oItem = Nothing

'Word郵件文檔下一節

docSource.MailMerge.DataSource.ActiveRecord = wdNextRecord

Next

rowCount

xlApp.Quit

'如果Outlook是由該宏打開的，則關閉Outlook

If

bStarted Then

'?oOutlookApp.Quit

End If

MsgBox "共發送了

" & lRecordCount - 1 & "

封郵件。"

'清空Outlook實例

Set

oOutlookApp = Nothing

Set xlApp =

Nothing

End Sub

總結

以上是生活随笔為你收集整理的word合并邮件无法发送html,Word邮件合并批量发送带附件的邮件的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。