Thank you for reading! I am completely new to this so be gentle :)
I am trying to mail merge to e-mail, including attachments with each message. I found this great article by Doug Robbins: http://word.mvps.org/faqs/mailmerge/...ttachments.htm
This article solved my problem, but unfortunately I found out that running the macro strips off all formatting as well as removing the images I had in my original document (I started the mail merge from Word).
Is there any way to alter the code below to send the message as it is (i.e. with formatting and pictures)?
Thank you very much for your help,
Sarah
PS: I am using Windows XP with Microsoft Office 2003.
Expand|Select|Wrap|Line Numbers
- 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