#1
|
|||
|
|||
Send Emails from MailMerge in Word using Specified Email Address
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 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 |
#2
|
||||
|
||||
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 ' Open the catalog mailmerge document and changing: .Send to: .SendUsingAccount = oOutlookApp.Session.Accounts.Item(x)
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
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 |
#4
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#5
|
|||
|
|||
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 |
#6
|
||||
|
||||
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
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#7
|
|||
|
|||
Brilliant!! Well done - that now works. I really appreciate your help.
|
Tags |
email, mailmerge |
|
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 |