Sub EmailMergeWithAttachments()
Dim Source As Document, Maillist As Document
Dim Datarange As Range, i As Long, j As Long, bStarted As Boolean
Dim mysubject As String, message As String, title As String
Dim oOutlookApp As Outlook.Application
Dim oAccount As Outlook.Account
Dim oItem As Outlook.MailItem
Set Source = ActiveDocument
' Open the catalog mailmerge document
With Dialogs(wdDialogFileOpen)
    .Show
End With
Set Maillist = ActiveDocument
If Maillist.FullName = Source.FullName Then Exit Sub
' 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
On Error GoTo 0
'Get the Outlook account to use
With oOutlookApp
  For Each oAccount In .Session.Accounts
    If oAccount.DisplayName = "norman@worldwidemission.org" Then Exit For
    ' Alternatively:
    'If oAccount.CurrentUser.Name = "Norman BaldEagle" Then Exit For
  Next
  Set oItem = .CreateItem(olMailItem)
  ' 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.Text
      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
      .SendUsingAccount = oAccount
      .Send
    End With
  Next j
  '  Close Outlook if it was started by this macro.
  If bStarted Then .Quit
End With
Maillist.Close wdDoNotSaveChanges 
MsgBox j & " messages have been sent."
'Clean up
Set oItem = Nothing: Set oOutlookApp = Nothing: Set Maillist = Nothing: Set Source = Nothing
End Sub