Send Emails from MailMerge in Word using Specified Email Address

Baldeagle · #1 07-24-2015, 08:00 AM

A colleague has this morning used the following Macro to send about 240 personalised emails generated through Word MailMerge.

Code:

Sub EmailMergeWithAttachments()
'
' EmailMergeWithAttachments Macro
'
'
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 + 1
            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

Unfortunately in spite of the fact that he had set his official IMAP email address as the default in Outlook all the emails were sent from his personal POP account.

I have come across the following code which is supposed to specify the email account to be used -

Code:

Public Sub New_Mail()
Dim oAccount As Outlook.Account
Dim oMail As Outlook.MailItem
 
For Each oAccount In Application.Session.Accounts
   If oAccount = "Name_of_Default_Account" Then
      Set oMail = Application.CreateItem(olMailItem)
      oMail.SendUsingAccount = oAccount
      oMail.Display
   End If
Next
End Sub

But I am not very proficient in writing code and would appreciate guidance on how I can adapt this code and insert it at an appropriate place in the Macro that is being used. Can somebody please tell me how and where this can be inserted and confirm that this will achieve the desired result?

macropod · #2 07-25-2015, 12:21 AM

I'm no Outlook expert, but I think you can do this by declaring a new variable:
x As Long
then inserting:

Code:

'Get the Outlook account to use
With oOutlookApp.Session.Accounts
  For x = 1 To .Count
    If .Item(x).CurrentUser.Name = "Name_of_Account_to_Use" Then Exit For
  Next
End With

before:
' Open the catalog mailmerge document
and changing:
.Send
to:
.SendUsingAccount = oOutlookApp.Session.Accounts.Item(x)

Baldeagle · #3 07-25-2015, 02:22 AM

Thanks Macropod for your suggestions. I think I have made the changes that you have suggested but although I get the message saying that 4 emails have been sent I can find no trace of them in any of my outboxes or sentboxes and none of them has arrived in the appropriate inboxes! Have I missed something?

Code:

Sub EmailMergeWithAttachments1()
'
' EmailMergeWithAttachments1 Macro
'
'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
Dim x As Long

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
'Get the Outlook account to use
With oOutlookApp.Session.Accounts
  For x = 1 To .Count
    If .Item(x).CurrentUser.Name = "norman@worldwidemission.org" Then Exit For
  Next
End With
' 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 + 1
            Set Datarange = Maillist.Tables(1).Cell(j, i).Range
            Datarange.End = Datarange.End - 1
            .Attachments.Add Trim(Datarange.Text), olByValue, 1
        Next i
        .SendUsingAccount = oOutlookApp.Session.Accounts.Item(x)
    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

macropod · #4 07-25-2015, 02:33 AM

A username isn't an email address - it's the name the person uses for that account. To use the email address, you need to change:
If .Item(x).CurrentUser.Name = "norman@worldwidemission.org" Then Exit For
to:
If .Item(x).DisplayName = "norman@worldwidemission.org" Then Exit For

Baldeagle · #5 07-25-2015, 03:17 AM

Same result!!??

Code:

Sub EmailMergeWithAttachments1()
'
' EmailMergeWithAttachments1 Macro
'
'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
Dim x As Long

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
'Get the Outlook account to use
With oOutlookApp.Session.Accounts
  For x = 1 To .Count
    If .Item(x).DisplayName = "norman@worldwidemission.org" Then Exit For
  Next
End With
' 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 + 1
            Set Datarange = Maillist.Tables(1).Cell(j, i).Range
            Datarange.End = Datarange.End - 1
            .Attachments.Add Trim(Datarange.Text), olByValue, 1
        Next i
        .SendUsingAccount = oOutlookApp.Session.Accounts.Item(x)
    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

macropod · #6 07-25-2015, 04:07 AM

As I said, I'm not an Outlook expert. Try the following. I believe it will work:

Code:

Sub EmailMergeWithAttachments()
Dim Source As Document, Maillist As Document
Dim Datarange As Range, i As Long, j As Long, bStarted As Boolean
Dim mysubject As String, message As String, title As String
Dim oOutlookApp As Outlook.Application
Dim oAccount As Outlook.Account
Dim oItem As Outlook.MailItem
Set Source = ActiveDocument
' Open the catalog mailmerge document
With Dialogs(wdDialogFileOpen)
    .Show
End With
Set Maillist = ActiveDocument
If Maillist.FullName = Source.FullName Then Exit Sub
' 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
On Error GoTo 0
'Get the Outlook account to use
With oOutlookApp
  For Each oAccount In .Session.Accounts
    If oAccount.DisplayName = "norman@worldwidemission.org" Then Exit For
    ' Alternatively:
    'If oAccount.CurrentUser.Name = "Norman BaldEagle" Then Exit For
  Next
  Set oItem = .CreateItem(olMailItem)
  ' 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.Text
      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
      .SendUsingAccount = oAccount
      .Send
    End With
  Next j
  '  Close Outlook if it was started by this macro.
  If bStarted Then .Quit
End With
Maillist.Close wdDoNotSaveChanges 
MsgBox j & " messages have been sent."
'Clean up
Set oItem = Nothing: Set oOutlookApp = Nothing: Set Maillist = Nothing: Set Source = Nothing
End Sub

Baldeagle · #7 07-25-2015, 05:32 AM

Brilliant!! Well done - that now works. I really appreciate your help.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Macro to send from non-default email address	k.n.	Mail Merge	5	12-03-2013 03:22 AM
Hyprelinks dropped out of email mailmerge after 500 of 1500 emails sent	Hazel Parker	Outlook	0	08-19-2012 06:20 PM
Outllok (2003) Rule to Send a New Email to a New Address upon Receipt of Specific Msg	Hendel	Outlook	1	10-27-2011 09:22 AM
unable to send test message Please verify the email address field	jarv	Outlook	0	04-30-2010 07:15 AM
Can't mailmerge emails with outlook & word 2007	chayden	Mail Merge	0	01-27-2010 08:19 AM