[Dan]

I am using the "Mail Merge to E-Mail with Attachments" macro witout success.
The macro appears to run three times (the number of e-mail addresses I am
using to test), but the test e-mail accounts do not receive the message.
Furthermore, I do NOT have messages in mu Outlook Outbox or sent messages
folder.

Did I inadvertently alter the macro? For the life of me, I can't find the
typo! Here 'tis:

Sub EMailMergeWithAttachments()

Dim Source As Document
Dim MailList As Document
Dim DataRange As Range
Dim Counter As Integer
Dim i As Integer
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim MySubject As String
Dim Message As String
Dim Title As String

Set Source = ActiveDocument

'Check if Outlook is running. Start it if it is not.
On Error Resume Next
If Err 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If

'Open the Catalog Mail Merge Document
With Dialogs(wdDialogFileOpen)
.Show
End With
Set MailList = ActiveDocument

'Show an Input box for the e-mail subject line
Message = "Enter the subject to be used for each e-mail message" 'Set the
dialog box prompt
Title = "E-Mail Subject Line:"
MySubject = InputBox(Message, Title)

'Iterate through the rows of the catalog mailmerge,
'extracting the info for the message

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
.Subject = MySubject
.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 = Nothng
ActiveDocument.Close wdDoNotSaveChanges
Counter = Counter + 1
Wend

'Close Outlook if started by the macro
If bStarted Then
oOutlookApp.Quit
End If

'Clean Up
Set oOutlookApp = Nothing
Source.Close wdDoNotSaveChanges
MailList.Close wdDoNotSaveChanges

End Sub

*****
Any help is appreciated. Thanks!

[Doug Robbins - Word MVP]

Looks OK.

Try sticking a

MsgBox DataRange

before

..to = DataRange

and make sure that it is being populated with a valid email address.
--
Hope this helps.

Please reply to the newsgroup unless you wish to avail yourself of my
services on a paid consulting basis.

Doug Robbins - Word MVP

"Dan" wrote in message
...
I am using the "Mail Merge to E-Mail with Attachments" macro witout
success.
The macro appears to run three times (the number of e-mail addresses I am
using to test), but the test e-mail accounts do not receive the message.
Furthermore, I do NOT have messages in mu Outlook Outbox or sent messages
folder.

Did I inadvertently alter the macro? For the life of me, I can't find the
typo! Here 'tis:

Sub EMailMergeWithAttachments()

Dim Source As Document
Dim MailList As Document
Dim DataRange As Range
Dim Counter As Integer
Dim i As Integer
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
Dim MySubject As String
Dim Message As String
Dim Title As String

Set Source = ActiveDocument

'Check if Outlook is running. Start it if it is not.
On Error Resume Next
If Err 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If

'Open the Catalog Mail Merge Document
With Dialogs(wdDialogFileOpen)
.Show
End With
Set MailList = ActiveDocument

'Show an Input box for the e-mail subject line
Message = "Enter the subject to be used for each e-mail message" 'Set the
dialog box prompt
Title = "E-Mail Subject Line:"
MySubject = InputBox(Message, Title)

'Iterate through the rows of the catalog mailmerge,
'extracting the info for the message

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
.Subject = MySubject
.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 = Nothng
ActiveDocument.Close wdDoNotSaveChanges
Counter = Counter + 1
Wend

'Close Outlook if started by the macro
If bStarted Then
oOutlookApp.Quit
End If

'Clean Up
Set oOutlookApp = Nothing
Source.Close wdDoNotSaveChanges
MailList.Close wdDoNotSaveChanges

End Sub

*****
Any help is appreciated. Thanks!