Create a Range for all email-addresses and send by Outlook/Excel

[espenskeie]

Hi

I have a loop in my email-code that send a separate email to each mailadress in column C. But I'm afraid that will not be a good solution when there'll be hundreds of contacts there.

I think it would be better to create a range by using a filter so that I only show those who are "active" (yes in column D). But how to I implement this into .BCC in my VBA?

Built on the ideas at Example Code for sending mail from Excel

Sub Mail()


' Denne skal passe til Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010,
' Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, Outlook 2010.
    
    Dim rng As Range
    Dim Stamp As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sFileName As String
    Dim preStrBody As String
    Dim sFileName1 As String
    Dim sFileName2 As String
    Dim postStrBody As String
    Dim DesktopOpen As String
    
    
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Sheets("Indigosec morning notes").Range("A1:M67").SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0


    'Setter adressen til folderen som skal legges på skrivebordet
    DesktopOpen = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    
    'Denne gir PDF-fila dagens dato
    Stamp = Format(Date, "DD.MM.YYYY")
    
    Sheets("SetUp").Activate
    
    'Adresse og navn til filen som skal være vedlagt
    sFileName = DesktopOpen & "\XYZ\Rapport_" & Stamp & ".pdf"
    
    'Om ønskelig en ekstrafil vedlagt?
    sFileName1 = DesktopOpen & "\XYZ\DailyReport.GIF"
    
    'Om ønskelig en ekstrafil vedlagt?
    sFileName2 = DesktopOpen & "\XYZ\eMail to PDF.xlsm"
    On Error Resume Next
   
For Each cell In Sheets("SetUp").Columns("C").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "D").Value) = "yes" Then
           
   Set OutApp = CreateObject("Outlook.Application")
   Set OutMail = OutApp.createitem(0)
   
        preStrBody = TEST
        
    '*****Imellom her kommer GIF-filen som viser rapporten i selve mailen (se .HTMLBody)
        
    postStrBody = "<br>" & "..................................................." _
                    & "<br><br>" & _
                    "CONFIDENTIALITY NOTICE:  This email is intended only for the person or entity to which it is addressed and may contain " & _
                    "confidential and/or privileged material. Delivery of this email or any of the information contained herein to anyone other than " & _
                    "the intended recipient or his designated representative is unauthorized and any other use, reproduction, distribution or " & _
                    "copying of this document or the information contained herein, in whole or in part, without the prior written consent of sender " & _
                    "or its affiliates is prohibited and may be unlawful. Any performance information contained herein may be unaudited and " & _
                    "estimated. Past performance is not necessarily an indication of future performance. If you have received this message in " & _
                    "error, please notify the sender immediately and delete this message and any related attachments. " _
                    & "<br><br>" & _
                    "..................................................." & "</P>"
                
               ' Dette feltet sier seg selv....
                With OutMail
                    .To = cell.Value 'Scanner igjennom lista og sender privat mail, en mail pr adresse,
                                     ' slik at det ikke er nødvendig med .BCC
                    .cc = ""
                    .BCC = ""
                    .Subject = "Morning notes - " & Stamp & ", Indigo Sec"
                    .Attachments.Add (sFileName) ''' Dette er PDF-fila
                    .Attachments.Add (sFileName2) ''' Dette er denne excelboka
                    .Attachments.Add (sFileName1) '''Dette er GIF-fila
                    .HTMLBody = preStrBody & "<img src=""cid:DailyReport.GIF"">" & postStrBody
                    
                    .NoAging = True
                                        
                    ' Tallet i parantes forteller hvilken konto du sender fra
                    .SendUsingAccount = OutApp.Session.Accounts.Item(1)
                    
                    .Display
                End With
                
                On Error GoTo 0
        Set OutMail = Nothing
        Set OutApp = Nothing
        Application.Wait (Now + TimeValue("0:00:02"))
        SendKeys "%{s}", True 'Denne overstyrer varselboksen om at noen forsøker å sende en mail fra Outlook
            
            End If
Next cell


End Sub

Kind regards
Espen

 

[espenskeie]

Found this link where it is described:
Excel Macro VBA - Send Emails through Outlook using Email Addresses from Excel and text from Word - Free Excel Macros VBA - TeachExcel.com