用word合併列印功發email並可夾帶附加檔案(幾個都可以)也可以CC或BCC Mail Merge to E-mail with Attachments

 感謝Doug Robbins & Graham Mayor - MS MVP (Word)，讓我可以使用word合併列印功發email並可夾帶附加檔案(幾個都可以)也可以設定CC或BCC，VBA Macro如下：但要先參閱下方網頁說明才知道如何運作。

https://wordmvp.com/FAQs/MailMerge/MergeWithAttachments.htm

https://www.maxwell.syr.edu/uploadedFiles/ict/Training/Handouts/Handout%20-%20EmailMergeWithAttachment(1).pdf

To run the macro in this procedure it is necessary to set a reference to the Microsoft Office Outlook Object Library. You do this from within the Visual Basic Editor, by selecting References from the Tool menu and then checking the item Microsoft Office Outlook ##.0 Object Library (where ## is the Outlook version number).

這是Doug Robbins，但發出去的email格式為plain text，如果發出去的格式要HTML的話要看Graham Mayor所提供的，我也PO在下方，這些我都有用，都可以WORK。

Sub emailmergewithattachments()

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

---

發出的email為HTML格式的VBA如下：

Sub emailmergewithattachments()
'
' emailmergewithattachments 巨集
'
'
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
            .BodyFormat = 2
            Set olInsp = .GetInspector
            Set wdDoc = olInsp.WordEditor
            Set oRng = wdDoc.Range
            'If you don't want the default signature, remove the next line
            oRng.Collapse 1
            .Display 'this must not be removed.
            .Subject = mysubject
            'oRng.FormattedText = Source.Sections(j).Range.FormattedText
            Source.Sections(j).Range.Copy
            oRng.Paste
            Set Datarange = Maillist.Tables(1).Cell(j, 1).Range
            Datarange.End = Datarange.End - 1
            .To = Datarange
            '.BCC = "amentinho@example.com"
            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