[[email protected]]

Hi have slightly modified Doug Robbin's code to merge 160 emails all
with attachments (some client specific, some generic). Thanks for code
Doug!!

From reading other posts in here, I gather the emails I send out (using
Word 2002 XP SP3) should retain formatting...but they don't.

Is there any extra code to send as HTML or is this just the default?

Code I'm using is:

Sub emailmergewithattachments()

Dim Source As Document, Maillist As Document
Dim Datarange As Range
Dim Counter As Integer, i As Integer
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 rows of the catalog mailmerge document,
extracting the information
' to be included in each email.

Counter = 1

While Counter = Maillist.Tables(1).Rows.Count
Source.Sections.First.Range.Copy
Documents.Add
Selection.Paste

' Add Name to first line

Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst, Count:=1,
Name:=""
Selection.TypeText Text:=Maillist.Tables(1).Cell(Counter, 1).Range
Selection.TypeParagraph
Selection.TypeParagraph


Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Subject = mysubject
.Body = ActiveDocument.Content
Set Datarange = Maillist.Tables(1).Cell(Counter, 2).Range
Datarange.End = Datarange.End - 1
.To = Datarange
For i = 3 To Maillist.Tables(1).Columns.Count
Set Datarange = Maillist.Tables(1).Cell(Counter, i).Range
Datarange.End = Datarange.End - 1
.Attachments.Add Trim(Datarange.Text), olByValue, 1
Next i
.Send HTML
End With
Set oItem = Nothing
ActiveDocument.Close wdDoNotSaveChanges
Counter = Counter + 1
Wend

' Close Outlook if it was started by this macro.
If bStarted Then
oOutlookApp.Quit
End If

'Clean up
Set oOutlookApp = Nothing
Source.Close wdDoNotSaveChanges
Maillist.Close wdDoNotSaveChanges

End Sub


Thanks
Simon