Bulk send Emails based on VBA Filtered Table from Excel-CodePudding

I frequently have to send out emails to various contractors to check in on the statuses of the projects I have bid with them. Currently I have to enter the name of each Rep in reference cell and then execute the macro but I deal with dozens of reps. I would like to be able to send an bulk email blast out to all the reps whose projects are still "Open" with one macro instead of having to change the reps name each time. Also, I tried to use the automatic .send function but cannot get it to work and I would hope to not have to keep using the .display for this situation for obvious reasons.

Sub EmailGCs_1()

    'Declare Outlook Variables
    Dim oLookApp As Outlook.Application
    Dim oLookItm As Outlook.MailItem
    Dim oLookIns As Outlook.Inspector

    'Declare Word Variables
    Dim oWrdDoc As Word.Document
    Dim oWrdRng As Word.Range
    Dim oWrdTble As Word.Table
     
    'Declare Excel Variables
    Dim ExcTbl As ListObject
         
    On Error Resume Next
    
    'Get The Active instance of Outlook, if there is one.
    Set oLookApp = GetObject(, "Outlook. Application")
    
        'If ther is no active instance create one
        If Err.Number = 429 Then
            
            'Create a new instance
            Set oLookApp = New Outlook.Application
    
                End If
      
        'Create a new Email
        Set oLookItm = oLookApp.CreateItem(olMailItem)

                
        'Create a refernce to the table
         Set Exltbl = ActiveSheet.ListOjects(1)

  With oLookItm
      
         'Basic Info
            .To = Range("D2").Value
            .Subject = "Various Project Statuses"
                                         
          'Display Email
             .Display
   
         'Get The Inspector
         Set oLookIns = .GetInspector
         
         'Get the Word Editor
         Set oWrdDoc = oLookIns.WordEditor
         
        'Filter Table to Distro
        ActiveSheet.Range("Table1").AutoFilter field:=6, Criteria1:=Cells(1, 6).Value
         
        'Hide Columns
        Range("G:R").EntireColumn.Hidden = True
         
        'Copy Items
         Worksheets(1).ListObjects("Table1").Range.Copy
         oWrdDoc.Range(1, 2).Paste
                       
         'Greeting Text
          MsgText = Split(Range("F1").Value, " ")(0) & "," & vbNewLine & "Can you please let me know the statuses of the projects below." & vbNewLine
          oWrdDoc.Range.InsertBefore Text:=MsgText
                         
        'Clearing out filter and selection
        ActiveSheet.ListObjects(1).AutoFilter.ShowAllData
        Application.CutCopyMode = False
        Range("G:R").EntireColumn.Hidden = False
        End With
           
    Set oLookItm = Nothing
    Set oLookApp = Nothing
    Application.ScreenUpdating = True

End Sub

CodePudding user response：

The Send method is not safe and the Outlook object model may trigger security prompts or give errors when Outlook is automated from an external application. Possible workarounds are listed below:

Create a COM add-in which deals with a safe Application instance which doesn't trigger security prompts.
Use a low-level code on which Outlook is built on and which doesn't have security riggers onboard. Or may also consider any other third-party wrappers around that API, for example, Redemption.
Use a third-party components for suppressing Outlook security warnings. See Security Manager for Microsoft Outlook for more information.
Use group policy objects for setting up machines.
Install any AV software with latest updates.

CodePudding user response：

Here is one way to loop through a list.

Source: Sending Email to a List of Recipients Using Excel and Outlook

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant


Sub EmailGCs_2()
    
    ' Early binding requires reference to Microsoft Outlook XX.X Object Library
    ' Declare Outlook variables
    Dim oLookApp As Outlook.Application
    Dim oLookItm As Outlook.MailItem
    
    Dim iCounter As Long
    
    'Application.ScreenUpdating = False
    
    'There can only be one instance of Outlook
    ' GetObject is not needed.
    ' The problematic On Error Resume Next can be dropped
    Set oLookApp = New Outlook.Application
    
    'Subsequent errors would have been bypassed
    ' due to the missing On Error GoTo 0
    'If there are any errors you can fix them now.
    
    'Assumes a list of email addresses in column D starting at cell D2
    ' https://docs.microsoft.com/en-us/office/vba/excel/concepts/working-with-other-applications/sending-email-to-a-list-of-recipients-using-excel-and-outlook
    
    'Debug.Print WorksheetFunction.CountA(Columns(4))   1
    For iCounter = 2 To WorksheetFunction.CountA(Columns(4))   1
    
        'Debug.Print iCounter
        
        'Create a new Email
        Set oLookItm = oLookApp.CreateItem(olMailItem)
        
        With oLookItm
          
            'Basic Info
            .To = Cells(iCounter, 4).Value
            .Subject = "Various Project Statuses"
                                             
            'Display Email
            .Display
            
        End With
        
        Set oLookItm = Nothing
        
    Next
    
    Set oLookItm = Nothing
    Set oLookApp = Nothing
    
    Application.ScreenUpdating = True
    
    Debug.Print "Done."

End Sub