use outlook group to send email using excel 2013 vba

[cmccabe]

The below vba will send an automated email to a list of addresses in excel 2013 using outlook 2013. Instead of having multiple email addresses in excel, if a distribution list was created in outlook, can that list be used instead?

For Example, the current code looks to column A, starting at row 2 for an email.... then it sends an email to each address.

A2=123@yahoo.com
A3=456@yahoo.com
A4=789@gmail.com

If each one of those email addresses was saved in an outlook group (email), could the group name (email) typed into A2 in the excel, then 3 separate emails sent? Thank you .


vba

Option Explicit


Public Sub EmailReport()

    Const sFIRST_ADDRESSEE_CELL As String = "A2"
    Const sATTACHMENT_NAME      As String = "Dose reporting form.xlsx"
    Const sCOMMENT_CELL_1       As String = "C1"
    Const sCOMMENT_CELL_2       As String = "D1"
    Const sREPORT_SHEET         As String = "Attachment"
    Const sEMAIL_SHEET          As String = "Email"
    Const sDATE_CELL            As String = "B2"

    Const iMAIL_ITEM            As Integer = 0
    Const sOUTLOOK              As String = "Outlook.Application"

    Dim sAttachmentFullName     As String
    Dim rAddresseeCells         As Range
    Dim wbkAttachment           As Workbook
    Dim objMailItem             As Object
    Dim objOutlook              As Object
    Dim wksEmail                As Worksheet
    Dim sMessage                As String
    Dim iYesNo                  As Integer
    Dim rCell                   As Range
    Dim frm                     As F01_CreateReport


'   Delete any pre-existing version of the temporary workbook which will be created
    If Dir$(sATTACHMENT_NAME) <> vbNullString Then
        Kill PathName:=sATTACHMENT_NAME
    End If

    Set wksEmail = ThisWorkbook.Sheets(sEMAIL_SHEET)

    iYesNo = MsgBox("Are there any issues to report", vbYesNoCancel)

    Select Case iYesNo

           Case vbYes

'               Create a copy of the Attachment worksheet
                ThisWorkbook.Sheets(sREPORT_SHEET).Copy

'               Save the above worksheet in a new temporary workbook and then set
'               the Saved property of the new workbook to False - this is needed
'               in order to pause VBA code execution until any changes to the
'               new workbook have been saved
                Set wbkAttachment = ActiveWorkbook

'               The worksheet to be saved contains code in its VBA CodeModule, but it
'               will be saved in a "Non-Macro Enabled" workbook - temporarily disable
'               Alerts to avoid the prompt which would otherwise occur during the Save
                Application.DisplayAlerts = False
                    wbkAttachment.SaveAs Filename:=sATTACHMENT_NAME
                Application.DisplayAlerts = True

                    wbkAttachment.Saved = False

'               Store the FullName of the new workbook so that it can be deleted later
                sAttachmentFullName = wbkAttachment.FullName

'               Inform the User to modify and then save the new workbook
                Set frm = New F01_CreateReport
                    frm.Show
                    Unload frm
                Set frm = Nothing


'               Now loop until the new workbook has been saved by the User
                Do
                    DoEvents
                Loop Until wbkAttachment.Saved = True

'               Close the new Workbook
                wbkAttachment.Close SaveChanges:=False

'               Determine the appropriate comment to be sent within the email
                sMessage = wksEmail.Range(sCOMMENT_CELL_2).Value

           Case vbNo

'               Determine the appropriate comment to be sent within the email
                sMessage = wksEmail.Range(sCOMMENT_CELL_1).Value

    End Select

    If iYesNo <> vbCancel Then

'       Finalise the message to be sent within the email
        sMessage = "For " & wksEmail.Range(sDATE_CELL).Value & _
                    vbLf & vbLf & _
                    sMessage

'       Determine how many emails need to be created
        With wksEmail.Range(sFIRST_ADDRESSEE_CELL)
             If .Offset(1, 0).Value <> vbNullString Then
                  Set rAddresseeCells = Range(.Cells(1, 1), _
                                              .End(xlDown))
             Else: Set rAddresseeCells = .Cells(1, 1)
             End If
        End With

'       Create an instance of Outlook
        Set objOutlook = CreateObject(sOUTLOOK)

'       Create as many emails as are required and then send them
        For Each rCell In rAddresseeCells

'           Create a single Email and populate it
            Set objMailItem = objOutlook.CreateItem(iMAIL_ITEM)

            With objMailItem

                .To = rCell
                .CC = vbNullString
                .BCC = vbNullString
                .Subject = "Daily Operational Safety Briefing"
                .Body = sMessage

'               Add the attachment workbook if it was created
                If Not wbkAttachment Is Nothing Then
                    .Attachments.Add sAttachmentFullName, 1
                End If

                .Send

            End With

        Next rCell

'       Confirm that the email(s) has/have been sent
        MsgBox "The data has been emailed sucessfully.", vbInformation

'       Delete the temporary attachment workbook if it was created
        If Not wbkAttachment Is Nothing Then

            On Error Resume Next
                Kill sAttachmentFullName
            On Error GoTo 0

        End If

        Set rAddresseeCells = Nothing
        Set wbkAttachment = Nothing
        Set objMailItem = Nothing
        Set objOutlook = Nothing
        Set wksEmail = Nothing
        Set rCell = Nothing

'       Exit and do not save
        ThisWorkbook.Close SaveChanges:=False
        Application.Quit

    End If

End Sub

Edit: I added

Const sSend As String "Email" and then updated the .To= sSend and. Display

The email address from the contact list from outlook does not transfer to excel and in the To is "Email"
Error: outlook does not recognize the address.

[shknbk2]

You can try the code below. I added a test to see if the rCell contains an 'at' (@) sign. If so, it processes it normally. If not, the code tries to assign a variable to a Contact item named after the rCell value. If it is successful, each member of the distribution list is send a separate email. This way, you can have a mixture of addresses and distribution lists in the rCell range.

The code below doesn't take into account any of your edit comments. I couldn't find what you meant by you had added the code indicated.

Option Explicit

Public Sub EmailReport()

    Const sFIRST_ADDRESSEE_CELL As String = "A2"
    Const sATTACHMENT_NAME      As String = "Dose reporting form.xlsx"
    Const sCOMMENT_CELL_1       As String = "C1"
    Const sCOMMENT_CELL_2       As String = "D1"
    Const sREPORT_SHEET         As String = "Attachment"
    Const sEMAIL_SHEET          As String = "Email"
    Const sDATE_CELL            As String = "B2"

    Const iMAIL_ITEM            As Integer = 0
    Const sOUTLOOK              As String = "Outlook.Application"

    Dim sAttachmentFullName     As String
    Dim rAddresseeCells         As Range
    Dim wbkAttachment           As Workbook
    Dim objMailItem             As Object
    Dim objOutlook              As Object
    Dim wksEmail                As Worksheet
    Dim sMessage                As String
    Dim iYesNo                  As Integer
    Dim rCell                   As Range
    Dim frm                     As F01_CreateReport
    Dim myDistList              As Object
    Dim lDistCount              As Long

'   Delete any pre-existing version of the temporary workbook which will be created
    If Dir$(sATTACHMENT_NAME) <> vbNullString Then
        Kill PathName:=sATTACHMENT_NAME
    End If

    Set wksEmail = ThisWorkbook.Sheets(sEMAIL_SHEET)

    iYesNo = MsgBox("Are there any issues to report", vbYesNoCancel)

    Select Case iYesNo

           Case vbYes

'               Create a copy of the Attachment worksheet
                ThisWorkbook.Sheets(sREPORT_SHEET).Copy

'               Save the above worksheet in a new temporary workbook and then set
'               the Saved property of the new workbook to False - this is needed
'               in order to pause VBA code execution until any changes to the
'               new workbook have been saved
                Set wbkAttachment = ActiveWorkbook

'               The worksheet to be saved contains code in its VBA CodeModule, but it
'               will be saved in a "Non-Macro Enabled" workbook - temporarily disable
'               Alerts to avoid the prompt which would otherwise occur during the Save
                Application.DisplayAlerts = False
                    wbkAttachment.SaveAs Filename:=sATTACHMENT_NAME
                Application.DisplayAlerts = True

                    wbkAttachment.Saved = False

'               Store the FullName of the new workbook so that it can be deleted later
                sAttachmentFullName = wbkAttachment.FullName

'               Inform the User to modify and then save the new workbook
                Set frm = New F01_CreateReport
                    frm.Show
                    Unload frm
                Set frm = Nothing

'               Now loop until the new workbook has been saved by the User
                Do
                    DoEvents
                Loop Until wbkAttachment.Saved = True

'               Close the new Workbook
                wbkAttachment.Close SaveChanges:=False

'               Determine the appropriate comment to be sent within the email
                sMessage = wksEmail.Range(sCOMMENT_CELL_2).Value

           Case vbNo

'               Determine the appropriate comment to be sent within the email
                sMessage = wksEmail.Range(sCOMMENT_CELL_1).Value

    End Select

    If iYesNo <> vbCancel Then

'       Finalise the message to be sent within the email
        sMessage = "For " & wksEmail.Range(sDATE_CELL).Value & _
                    vbLf & vbLf & _
                    sMessage

'       Determine how many emails need to be created
        With wksEmail.Range(sFIRST_ADDRESSEE_CELL)
             If .Offset(1, 0).Value <> vbNullString Then
                  Set rAddresseeCells = Range(.Cells(1, 1), _
                                              .End(xlDown))
             Else: Set rAddresseeCells = .Cells(1, 1)
             End If
        End With

'       Create an instance of Outlook
        Set objOutlook = CreateObject(sOUTLOOK)

'       Create as many emails as are required and then send them
        For Each rCell In rAddresseeCells

            If InStr(1, rCell, "@") > 0 Then
'               Create a single Email and populate it
                Set objMailItem = objOutlook.CreateItem(iMAIL_ITEM)
    
                With objMailItem
    
                    .To = rCell.Value
                    .CC = vbNullString
                    .BCC = vbNullString
                    .Subject = "Daily Operational Safety Briefing"
                    .Body = sMessage
'                   Add the attachment workbook if it was created
                    If Not wbkAttachment Is Nothing Then
                        .Attachments.Add sAttachmentFullName, 1
                    End If
                    .Send
                End With
            Else
                On Error Resume Next
                Set myDistList = objOutlook.getnamespace("MAPI").GetDefaultFolder(10) _
                    .Items(rCell.Value)
                On Error GoTo 0
                If Not myDistList Is Nothing Then
                    If myDistList.Class = 69 Then
                        For lDistCount = 1 To myDistList.MemberCount
                            Set objMailItem = objOutlook.CreateItem(iMAIL_ITEM)
                            With objMailItem
                                .To = myDistList.GetMember(lDistCount).Address
                                .CC = vbNullString
                                .BCC = vbNullString
                                .Subject = "Daily Operational Safety Briefing"
                                .Body = sMessage
                                If Not wbkAttachment Is Nothing Then
                                    .Attachments.Add sAttachmentFullName, 1
                                End If
                                .Send
                            End With
                        Next
                    End If
                End If
            End If
        Next rCell

'       Confirm that the email(s) has/have been sent
        MsgBox "The data has been emailed sucessfully.", vbInformation

'       Delete the temporary attachment workbook if it was created
        If Not wbkAttachment Is Nothing Then

            On Error Resume Next
                Kill sAttachmentFullName
            On Error GoTo 0

        End If

        Set rAddresseeCells = Nothing
        Set wbkAttachment = Nothing
        Set objMailItem = Nothing
        Set objOutlook = Nothing
        Set wksEmail = Nothing
        Set rCell = Nothing

'       Exit and do not save
        ThisWorkbook.Close SaveChanges:=False
        Application.Quit

    End If

End Sub

[cmccabe]

Where is the distribution group to use specified or how does the vba know to use the (email) group? Thank you

The edit was an attempt at trying to achieve this, but it did not work.

edit: I see now, it works great.... thank you very much