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