Having a slight problem. This code works, my biggest issue was getting a loop so I can do the bulk emails here at work, but not have individual emails. This is basically "newsletter" and surveys for various teams. There can be up to 5K names on one list. Anyways, since Outlook has a maximum of 500, the loop was set for 500. Works great, my issue is trying to use Change Notification.oft file. Before I was able to get this loop to work, I was able to get a different macro to work that used the template. Now I just want to add that part to this macro code. But it appears I have been unsuccessful in doing so. And if you could possibly assist in one more part of this code, I am trying to make sure that when these emails are sent that no signature is on the emails, is that possible? I have not been able to find anything. Thanks in advance for all your help!!!
Option Explicit
Sub Emailtest()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailTo As String
Dim LastRw As Long
Dim i As Integer
' Set Outlook object.
Set OutApp = CreateObject("Outlook.Application")
' Change to path of OFT Template
Set OutMail = OutApp.CreateItemFromTemplate("C:Usersbarnes22AppDataRoamingMicrosoftTemplatesChange Notification.oft")
LastRw = Range("B" & Rows.Count).End(xlUp).Row
' Loop of 500 email addresses
For i = 2 To LastRw Step 500
EmailTo = Join(Application.Transpose(Sheet7.Range("B" & i & ":B" & WorksheetFunction.Min(i + 99, LastRw)).Value), ";")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = EmailTo
.CC = ""
.BCC = ""
.Display
'.send
End With
Next i
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Remove this line:
Set OutMail = OutApp.CreateItem(0)
Do you not have distribution lists at work?
@Velouria,
I removed that line like you said and it kind of worked. An email was generated with the template (OFT) file), however it was only 1 email with about 100 names. My test file has about 1300, and with a loop of 500, there should be a total of 500 emails. Previously it created the multiple emails as it is supposed to. I am not sure why it is not creating the multiple emails with the template since I removed that one line of code.
Yes we do have DL here. But the creation and management of them has to go through IT. I had one created to test if this would work for a project. I created a list, attached the Excel file as requested (152 names/emails), there was NO communication that it was completed (I just happen to check status and find out. Then there were 0 names, I exported the file, yup, that is correct. They created the list, but did not add the names. I am waiting for an answer as to why, as I was told if there are a large number of additions/deletions we should go through IT. It is not something IT can apparently manage.
My team needs to be able to update on the fly as needs arrive and we have determined that the Outlook with the macro works for our needs.
Your IT department should be fired - that's pretty basic stuff. 🙂
You need to put this line:
Set OutMail = OutApp.CreateItemFromTemplate("C:Usersbarnes22AppDataRoamingMicrosoftTemplatesChange Notification.oft")
inside the loop where the line you deleted was, so that you get a new template email created for each set of names.
I discovered a typo in my code, I previously used this code with a loop of 100, but now I am using the Outlook max of 500. The text in red is my correction. This code is now adding the template, but there is 1 email instead of 3, and the email is for the last 345 names on the Excel list. The first 2 emails (of 500 each) were never generate
Sub Emailtest()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailTo As String
Dim LastRw As Long
Dim i As Integer
' Set Outlook object.
Set OutApp = CreateObject("Outlook.Application")
' Change to path of OFT Template
Set OutMail = OutApp.CreateItemFromTemplate("C:Usersbarnes22AppDataRoamingMicrosoftTemplatesChange Notification.oft")
LastRw = Range("B" & Rows.Count).End(xlUp).Row
' Loop of 500 email addresses
For i = 2 To LastRw Step 500
' Sheet where email List is located
EmailTo = Join(Application.Transpose(Sheet2.Range("B" & i & ":B" & WorksheetFunction.Min(i + 499, LastRw)).Value), ";")
With OutMail
.To = EmailTo
.CC = ""
.BCC = ""
.Display
'.send
End With
Next i
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Put the Set outMail =… line before the With outMail line.
@Velouria,
Jackpot!!!!! Such a simple fix, I knew I was close!!!!! Thank you so very much! I have been working on this project for so very long!!!! I cannot thank you enough for your help with this one. And my team thanks you too. Wait until I tell them you helped me find a final fix for this code. This is a great Monday!!!!
