Code to create individual e-mail messages

[Damian40]

Hello Everyone,
I'm currently using the following VBA script to run an auto e-mail within an Excel workbook. However, currently the workbook needs to be open and a macro button needs to be clicked in order for the e-mail to be created and sent. Another thing is the e-mail is currently sending to multiple users that are retrieved from a specific column and placed within the BCC column in order for them to be unable to view all of the recipients.
I would like to modify the code to include a new column containing point of contact e-mail addresses, as well as have the macro built so the user can simply click a button within their desktop and have the e-mails created and sent whether the Excel file is open or closed. I would also like to be able to break up the e-mails to be individual e-mails sent to the vendor and point of contact for that vendor instead of multiple recipients all within the BCC section. Here is the code I'm currently using:



Sub Button2_Click()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)

Worksheets("Agreements").Activate

With OutLookMailItem
MailDest = ""
For iCounter = 2 To WorksheetFunction.CountA(Columns(28))
If Len(Cells(iCounter, 28).Offset(0, -1)) > 0 Then
If MailDest = "" And Cells(iCounter, 28).Offset(0, -1) = "EXPIRED" Then
MailDest = Cells(iCounter, 28).Value
ElseIf MailDest <> "" And Cells(iCounter, 28).Offset(0, -1) = "EXPIRED" Then
MailDest = MailDest & ";" & Cells(iCounter, 28).Value
End If
End If
Next iCounter
.To = generic e-mail
.BCC = MailDest
.Subject = "Insurance Verification"
.HTMLBody = "To Whom It May Concern,
" _
& "Please be advised the certificate of insurance we have on file has expired. " _
& "Please provide an updated certificate of insurance as quickly as possible. " _
& "We are currently out of compliance.
" _
& "Please email updated policy to e-mail address
" _
& "Thank You,
" & "John Doe
" _
& "Internal Auditor
" & "Central Region
" _
& "123 American Highway
" & "City, ST 11111
" _
& "Phone: 954-999-9999 Ext. 123-4567"
.Display '.Send
End With
Set OutLookMailItem = Nothing
Set OutLookApp = Nothing
End Sub


I was thinking perhaps I could possibly add this bit of code after the Next iCounter line in the existing code:


MailDest2 = ""
For iCounter2 = 2 To WorksheetFunction.CountB(Columns(29))
If Len(Cells(iCounter2, 29).Offset(0, -2)) > 0 Then
If MailDest2 = "" And Cells(iCounter2, 29).Offset(0, -2) = "EXPIRED" Then
MailDest2 = Cells(iCounter, 29).Value
ElseIf MailDest2 <> "" And Cells(iCounter2, 22).Offset(0, -2) = "EXPIRED" Then
MailDest2 = MailDest2 & ";" & Cells(iCounter2, 29).Value
End If
End If
Next iCounter2
.To = MailDest2 generic e-mail
.CC = MailDest
.BCC = generic e-mail


If this is possible, would I need to repeat the With OutlookMailItem line, or can I simply add the additional code below the Next iCounter line?
Any and all help is greatly appreciated! Thank you very much!
Damian

[gmayor]

At present you appear to have a loop that gathers the recipients and creates a single message with all the recipients as BCC (which creates separate messages when seen by the recipients). To create separate individual messages then you need to create those messages inside the loop with the recipient as the cell value.

The desktop button is a more difficult issue. You cannot do that with VBA. You would need to start Excel in order to run the code it contains. I guess the best that you could manage is a link to macro enabled workbook with the code run from an auto macro that runs when the workbook opens.

[Damian40]

At present you appear to have a loop that gathers the recipients and creates a single message with all the recipients as BCC (which creates separate messages when seen by the recipients). To create separate individual messages then you need to create those messages inside the loop with the recipient as the cell value.

The desktop button is a more difficult issue. You cannot do that with VBA. You would need to start Excel in order to run the code it contains. I guess the best that you could manage is a link to macro enabled workbook with the code run from an auto macro that runs when the workbook opens.

Hi gmayor,
Thank you for the advice...question, would I be creating multiple with statements one after the other within the overall If statement? Or would I perhaps use Else If statement within the initial If statement. I guess my confusion lies in how would I be able to differentiate and identify the multiple e-mail addresses within the To line for the e-mail. Same holds true for the CC line that will include the various points of contact and static Contract Coordinator e-mail address. I understand If statements, and Else If, but I'm drawing a blank as to how to go about assigning the unique e-mail addresses within the 28th column.

[Damian40]

Hello Everyone,
I've figured out how to modify my code to send out individual e-mails to anyone that may have an expired contract. However, I'm still a bit unsure how I should go about adding the additional e-mail address of my companies point of contact working with each particular vendor. I've copied my current code, and I was hoping someone might have a suggestion as to how I can add an additional line to include the point of contact's e-mail address to the CC line of the e-mail.



Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String

Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)

Worksheets("Agreements").Activate



For iCounter = 2 To WorksheetFunction.CountA(Columns(28))

MailDest = ""
'MailDest2 = ""
If Len(Cells(iCounter, 28).Offset(0, -1)) > 0 Then
If MailDest = "" And Cells(iCounter, 28).Offset(0, -1) = "EXPIRED" Then
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
MailDest = Cells(iCounter, 28).Value
.To = MailDest
.BCC = BCC
.Subject = "Insurance Verification"
.HTMLBody = "To Whom It May Concern,<p>" _
& "Please be advised the certificate of insurance we have on file has expired. " _
& "Please provide an updated certificate of insurance as quickly as possible. " _
& "We are currently out of compliance.<p>" _
& "Please email updated policy to generic e-mail <p>" _
& "Thank You,<p>" & "<b>John Doe</b><br>" _
& "Auditor<br>" & "Region<br>" _
& "Anywhere Street<br>" & "America, US 12345<br>" _
& "Phone: 999-999-9999Ext. 123-4567"

.Display
End With
End If


End If

Next iCounter



I thought perhaps if I added an additional MailDest line and called it MailDest2, assigning the values within the 29th column might do the trick. Maybe something like this:



MailDest = ""
MailDest2 = ""
If Len(Cells(iCounter, 28).Offset(0, -1)) > 0 Then
If MailDest = "" And Cells(iCounter, 28).Offset(0, -1) = "EXPIRED" Then
ElseIf MailDest2 = "" And Cells(iCounter, 29).Offset(0, -2) = "EXPIRED" Then
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
MailDest = Cells(iCounter, 28).Value
MailDest2 = Cells(iCounter, 29).Value
.To = MailDest
.CC = MailDest2; generic static e-mail address

[Damian40]

Hello Everyone,
Just an update...I played around with the code and got it to work the way I needed it to. Not entirely sure if this is the most efficient way to write the code so I thought I would reply to my thread with my updated code. If anyone sees anything that can be improved and would like to share, that would be awesome! Thanks so much!

Still trying to figure out how to create code so the user can simply click a button on their desktop to run the macros to open the file, review the information, and auto-send any e-mails that need to be sent out. If anyone has any suggestions or ideas for that, that would also be very much appreciated. Thanks again for looking at this post!



Sub Button2_Click()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Dim iCounter As Integer
Dim MailDest As String
Dim MailDest2 As String

Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)

Worksheets("Agreements").Activate

For iCounter = 2 To WorksheetFunction.CountA(Columns(29))

MailDest = ""

If Len(Cells(iCounter, 28).Offset(0, -1)) > 0 Then
If MailDest = "" And Cells(iCounter, 28).Offset(0, -1) = "EXPIRED" Then

Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem

MailDest = Cells(iCounter, 28).Value
MailDest2 = Cells(iCounter, 29).Value

.To = MailDest
.CC = MailDest2
.BCC = Generic e-mail
.Subject = "Insurance Verification"
.HTMLBody = "To Whom It May Concern,<p>" _
& "Please be advised the certificate of insurance we have on file has expired. " _
& "Please provide an updated certificate of insurance as quickly as possible. " _
& "We are currently out of compliance.<p>" _
& "Please email updated policy to generic e-mail <p>" _
& "Thank You,<p>" & "<b>John Doe</b><br>" _
& "Regional Contracts Administrator<br>" & "Florida Region<br>" _
& "123 American Highway<br>" & "Anywhere, St 12345<br>" _
& "Phone: 123-456-7890Ext. 123-7890"

'.Display
.Send
End With

End If

End If

Next iCounter

Set OutLookMailItem = Nothing
Set OutLookApp = Nothing