Create A .BCC email in Outlook Using a Range of Cells from excel and a checkbox

[nmullz]

Hello, I am a newbie to VBA in general and I'm quite confused.

I want to create a macro enabled check box that when checked, will open up a draft email in outlook and have the email list (in range A1:A50) populate the .BCC field of the email. The email list is constantly changing as I have created a separate macro to add or delete emails based on necessity.
I'm not exactly sure how to write the code so if someone could help me out it would be greatly appreciated.

Thanks!

 

[mrmmickle1]

nmullz,

Try something like this adapted from Ron De Bruin:

[COLOR=#0000ff]Sub [/COLOR]Mail_workbook_Outlook_1()

    [COLOR=#0000ff]Dim[/COLOR] OutApp    [COLOR=#0000ff]As Object[/COLOR]
   [COLOR=#0000ff] Dim [/COLOR]OutMail [COLOR=#0000ff]  As Object[/COLOR]
 [COLOR=#0000ff]   Dim[/COLOR] EmailArr [COLOR=#0000ff] As Variant[/COLOR]
[COLOR=#0000ff]    Dim [/COLOR]RowEnd    [COLOR=#0000ff]As Integer[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] RowStart  [COLOR=#0000ff]As Integer
[/COLOR]    [COLOR=#0000ff]Dim[/COLOR] BCCString [COLOR=#0000ff]As String[/COLOR]

  [COLOR=#0000ff]  Set [/COLOR]OutApp = CreateObject("Outlook.Application")
  [COLOR=#0000ff]  Set [/COLOR]OutMail = OutApp.CreateItem(0)
    RowStart = 1 [COLOR=#008000]'Assumes No Header, Row to Start Email List On[/COLOR]
    RowEnd = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row [COLOR=#008000]'Find last Row in column A with data[/COLOR]
    EmailArr = Range(Cells(RowStart, 1), Cells(RowEnd, 1)) [COLOR=#008000]'Define Dynamic Array[/COLOR]

[COLOR=#0000ff]    On Error Resume Next      [/COLOR][COLOR=#008000]'Supress Errors[/COLOR]
       [COLOR=#0000ff] For [/COLOR]i = 1 [COLOR=#0000ff]To[/COLOR] RowEnd
         [COLOR=#0000ff] If [/COLOR]i <> RowEnd [COLOR=#0000ff]Then[/COLOR]
               BCCString = BCCString & EmailArr(i, 1) & "; " [COLOR=#008000]'Add Semicolon onto email string (BCCString)[/COLOR]
[COLOR=#0000ff]             Else[/COLOR]
               BCCString = BCCString & EmailArr(i, 1) [COLOR=#008000] 'Do not add Semicolon to last email address[/COLOR]
[COLOR=#0000ff]          End If[/COLOR]     
       [COLOR=#0000ff] Next[/COLOR] i
    
 [COLOR=#0000ff]   With [/COLOR]OutMail
        .To = ""  [COLOR=#008000]'Add To as necessary[/COLOR]
        .CC = "" [COLOR=#008000] 'Add CC as necessary[/COLOR]
        .BCC = BCCString
        .Subject = "This is the Subject line"
        .Body = "This is the Email Body"
        .Send
[COLOR=#0000ff]    End With[/COLOR]
   [COLOR=#0000ff] On Error GoTo 0  [/COLOR]'[COLOR=#008000]Reset Error Handling[/COLOR]
    
  [COLOR=#008000]  'Clear Memory
[/COLOR]    BCCString = vbNullString
    [COLOR=#0000ff]Set [/COLOR]OutMail = [COLOR=#0000ff]Nothing[/COLOR]
  [COLOR=#0000ff]  Set[/COLOR] OutApp = [COLOR=#0000ff]Nothing[/COLOR]
    EmailArr = [COLOR=#0000ff]Empty[/COLOR]
    RowEnd = [COLOR=#0000ff]Empty[/COLOR]
    RowStart = [COLOR=#0000ff]Empty[/COLOR]

[COLOR=#0000ff]End Sub[/COLOR]

Welcome to the board!!! Hope this helps.

 

[nmullz]

Thanks for the help. Assuming i do have a 1st row header, how would i edit that code in order to compensate for that. Also I added

If Range("Z3")= TRUE Then -----> Which is my assigned check box and format control cell

(Body of Code)

End If

I get an error while running the code, and the VBA editor highlights
" Set OutApp = CreateObject("Outlook.Application")"
and Outlook doesn't open an editable email

is there any solution to that?

Thanks

 

[mrmmickle1]

Not Sure why that is happening...hmmmm

To fix that error try going into the VBE. Look at the top of the screen:

1. Click on Tools>References
2. Add Microsoft Outlook 15.0 Object Library (Could be a different number like 14.0)

Then run the code again. If it does not work then please report back the error description and I will try to assist you further.

As far as the additions you requested. Try editing the code to this: Since TRUE is a reserved word in VBA. I'm not sure that you can go by the value in Range("Z3") so I added a MsgBox to ask the user if they want to distribute the emails.... Red Lines Are New or changed

[COLOR=#0000ff]Sub[/COLOR] Mail_workbook_Outlook_1()


   [COLOR=#0000ff] Dim [/COLOR]OutApp       [COLOR=#0000ff]As Object[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] OutMail      [COLOR=#0000ff]As Object[/COLOR]
[COLOR=#0000ff]    Dim[/COLOR] EmailArr     [COLOR=#0000ff]As Variant[/COLOR]
   [COLOR=#0000ff] Dim[/COLOR] RowEnd      [COLOR=#0000ff] As Integer[/COLOR]
    [COLOR=#0000ff]Dim[/COLOR] RowStart     [COLOR=#0000ff]As Integer[/COLOR]
  [COLOR=#0000ff]  Dim [/COLOR]BCCString   [COLOR=#0000ff] As String[/COLOR]
[B][COLOR=#ff0000]    Dim ApprRejQues  As String[/COLOR][/B]
    
    [B][COLOR=#ff0000]ApprRejQues = MsgBox("If You would like to send emails click Yes otherwise click No", vbYesNo, "Email Distribution Prompt")
      If ApprRejQues = vbYes Then[/COLOR][/B]
           [COLOR=#0000ff] Set[/COLOR] OutApp = CreateObject("Outlook.Application")
            [COLOR=#0000ff]Set[/COLOR] OutMail = OutApp.CreateItem(0)
          
          [B][COLOR=#ff0000]  RowStart = 2 [/COLOR][/B][COLOR=#008000]'Assumes Header is Present[/COLOR]
            RowEnd = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row [COLOR=#008000]'Find last Row in column A with data[/COLOR]
            EmailArr = Range(Cells(RowStart, 1), Cells(RowEnd, 1)) [COLOR=#008000]'Define Dynamic Array[/COLOR]
        
            [COLOR=#0000ff]On Error Resume Next   [/COLOR]  [COLOR=#008000] 'Supress Errors[/COLOR]
          [B][COLOR=#ff0000]      For i = 1 To RowEnd - 1[/COLOR][/B]
             [COLOR=#ff0000][B]     If i <> RowEnd - 1 Then[/B][/COLOR]
                       BCCString = BCCString & EmailArr(i, 1) & "; "[COLOR=#008000] 'Add Semicolon onto email string (BCCString)[/COLOR]
[COLOR=#0000ff]                     Else[/COLOR]
                       BCCString = BCCString & EmailArr(i, 1)  [COLOR=#008000]'Do not add Semicolon to last email address[/COLOR]
[COLOR=#0000ff]                  End If[/COLOR]
             [COLOR=#0000ff]   Next[/COLOR] i
            
          [COLOR=#0000ff]  With [/COLOR]OutMail
              [B][COLOR=#ff0000]  .Display [/COLOR][/B] [COLOR=#008000]'Makes Outlook Mail Visible[/COLOR]
                .To = ""  [COLOR=#008000]'Add To as necessary[/COLOR]
                .CC = "" [COLOR=#008000] 'Add CC as necessary[/COLOR]
                .BCC = BCCString
                .Subject = "This is the Subject line"
                .Body = "This is the Email Body"
              [B][COLOR=#ff0000]  '.Send [/COLOR][/B][COLOR=#008000]'This line of code has been commented out so the email is not sent[/COLOR]
[COLOR=#0000ff]            End With[/COLOR]
           [COLOR=#0000ff] On Error GoTo 0[/COLOR]  [COLOR=#008000]'Reset Error Handling[/COLOR]
      [B][COLOR=#ff0000]  Else
            MsgBox "No Emails Will Be Sent!!", vbCritical, "Email Distribution Aborted"
        Exit Sub
      End If[/COLOR][/B][COLOR=#0000ff]
[/COLOR]     
[COLOR=#008000]           'Clear Memory
[/COLOR]         [B][COLOR=#ff0000]   ApprRejQues = vbNullString[/COLOR][/B]
            BCCString = vbNullString
            [COLOR=#0000ff]Set [/COLOR]OutMail = [COLOR=#0000ff]Nothing[/COLOR]
          [COLOR=#0000ff]  Set[/COLOR] OutApp = [COLOR=#0000ff]Nothing[/COLOR]
            EmailArr = [COLOR=#0000ff]Empty[/COLOR]
            RowEnd = [COLOR=#0000ff]Empty[/COLOR]
            RowStart = [COLOR=#0000ff]Empty[/COLOR] 

[COLOR=#0000ff]End Sub[/COLOR]