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