Option Explicit

Sub MailMergeWithCcAndAttachments()
Dim Source As Document, MailList As Document, TempDoc As Document
Dim Datarange As Range, Recipient As Range, CC1 As Range, CC2 As Range
Dim i As Long, j As Long, bStarted As Boolean, objDoc, objSel
Dim oOutlookApp As Outlook.Application, oItem As Outlook.MailItem
Dim MySubject As String, Message As String, Title As String

' Run the MailMerge to Letters
ActiveDocument.MailMerge.Execute

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 MailMerge Catalog/Directory document (MailingList.docx)
Dialogs(wdDialogFileOpen).Show
Set MailList = ActiveDocument
' Show an input box asking the user for the email subject to be used.
' Display message of input box, title
MySubject = InputBox("Enter the subject to be used for each email.", "Email Subject Input")

' Iterate through the Sections of the Source document and the rows of the MailMerge Catalog/Directory document,
' extracting the information to be included in each email.
For j = 1 To Source.Sections.Count - 1
    Source.Sections(j).Range.Copy
    Set oItem = oOutlookApp.CreateItem(olMailItem)
    With oItem
        .Subject = MySubject
        .BodyFormat = olFormatHTML
        .Body = Source.Sections(j).Range.FormattedText
        .Display
        Set objDoc = .GetInspector.WordEditor
        Set objSel = objDoc.Windows(1).Selection
        objSel.Paste
        Set Recipient = MailList.Tables(1).Cell(j, 1).Range
        Recipient.End = Recipient.End - 1
        Set CC1 = MailList.Tables(1).Cell(j, 2).Range
        CC1.End = CC1.End - 1
        Set CC2 = MailList.Tables(1).Cell(j, 3).Range
        CC2.End = CC2.End - 1
        .To = Recipient.Text
        .CC = CC1.Text & "; " & CC2.Text
        ' To obtain the file path for the attachment from the MailMerge Catalog/Directory document.
        For i = 4 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
Source.Close wdDoNotSaveChanges
MailList.Close wdDoNotSaveChanges
' Close Outlook if it was started by this macro.
If bStarted Then oOutlookApp.Quit
MsgBox Source.Sections.Count - 1 & " message(s) have been sent."
'Clean up
Set Recipient = Nothing: Set oOutlookApp = Nothing: Set Source = Nothing
Set oItem = Nothing: Set objDoc = Nothing: Set objSel = Nothing
End Sub