Sub emailmergewithattachments()
'To create the email messages in HTML format
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
source.Sections(j).Range.Copy
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Subject = mysubject
.BodyFormat = olFormatHTML
.Display
Set objDoc = .GetInspector.WordEditor
Set objSel = objDoc.Windows(1).Selection
objSel.Paste
Set datarange = Maillist.Tables(1).Cell(j, 1).Range
datarange.End = datarange.End - 1
.To = datarange
.cc = ; "
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 & " messages have been sent."
'Clean up
Set oOutlookApp = Nothing
End Sub