View Single Post
  #4  
Old September 8th, 2009, 02:51 PM posted to microsoft.public.word.mailmerge.fields
Graham Mayor
external usenet poster
 
Posts: 18,297
Default Mail merge Attachment problems

The following is a version of Doug's earlier macro which works for me and
adds the Subject selection. I'll mention the other problem to him for when
he gets back.

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 sSubject As String
Set Source = ActiveDocument
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
With Dialogs(wdDialogFileOpen)
.Show
End With
sSubject = InputBox("Enter subject for all the messages", "E-Mail Subject")
Set Maillist = ActiveDocument
Counter = 1
While Counter = Maillist.Tables(1).Rows.Count
Source.Sections.First.Range.Cut
Documents.Add
Selection.Paste
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Body = ActiveDocument.Content
.Subject = sSubject
Set Datarange = Maillist.Tables(1).Cell(Counter, 1).Range
Datarange.End = Datarange.End - 1
.To = Datarange
For i = 2 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
End With
Set oItem = Nothing
ActiveDocument.Close wdDoNotSaveChanges
Counter = Counter + 1
Wend
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub


--

Graham Mayor - Word MVP

My web site www.gmayor.com
Word MVP web site http://word.mvps.org



Graham Mayor wrote:
I assume that you must be referring to Doug's macro
http://word.mvps.org/FAQs/MailMerge/...ttachments.htm ?
I thought there was something amiss when you mentioned that the macro
prompted for a subject, whereas my older copy of Doug's macro doesn't
do that. The older copy - listed below - does work correctly. I
briefly tested the version currently on the web site and that doesn't
work for me. It either merges just one record or none. No doubt Doug
will be along later (if he is back from holiday) to put it right. If
not I will take a look this afternoon when I have a bit more time.

Interestingly, I no longer get the prompt to confirm every record from
Office 2007. I am not currently running ClickYes. I haven't tested
with Office 2003 yet. That too will have to wait until later.

If merging with attachments from Word is going to be a feature of your
employment, you could suggest to your IT department that they install
MAPILab's Mailmerge toolkit add-in for Outlook
http://www.mapilab.com/outlook/mail_merge/ which adds a few more
bells and whistles to the process. But the basic core of Doug's macro
(below) works as stated - it's just the current iteration on the web
page that seems to have wobbled.


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
Set Source = ActiveDocument
On Error Resume Next
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
With Dialogs(wdDialogFileOpen)
.Show
End With
Set Maillist = ActiveDocument
Counter = 1
While Counter = Maillist.Tables(1).Rows.Count
Source.Sections.First.Range.Cut
Documents.Add
Selection.Paste
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.Body = ActiveDocument.Content
Set Datarange = Maillist.Tables(1).Cell(Counter, 1).Range
Datarange.End = Datarange.End - 1
.To = Datarange
For i = 2 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
End With
Set oItem = Nothing
ActiveDocument.Close wdDoNotSaveChanges
Counter = Counter + 1
Wend
If bStarted Then
oOutlookApp.Quit
End If
Set oOutlookApp = Nothing
End Sub



Back2Basics wrote:
I have been trying to send a series of email using the mail merge so
that associated attachments are sent with each email - different for
each email address.

I am aware that there is a piece of code that is meant to sort this
out for me, I have tried using it and it doesn't seem to be working
as it should. I set up a test spreadsheet with 10 cells with my email
address in and 10 cells with different files paths in the next
column. I followed all of the directions for the VBA Code and
eventually got to a stage where i was prompted for the subject for
the email and then it continued to - what I thought was send the
emails.

I was sat there for a few minutes clicking yes to all of the
messages, I know there is a program for this but I can not DL at
work. After clicking well over 30 times I tried to stop, ended up
ending the task through the task list. Why do i have to click over
30 times when I am only sending 10 emails? And why after clicking
over 30 times did I not recieve a single email?

Can anyone help me on this issue?

TIA