在Excel中批量发送基于VBA过滤表的邮件

Question

我经常不得不给不同的承包商发邮件，检查我与他们投标的项目的状态。目前，我必须在参考单元格中输入每个代表的名称，然后执行宏，但我处理数十个代表。我希望能够向所有项目仍然"开放"的代表发送批量电子邮件。使用一个宏，而不必每次都更改代表名称。此外，我试图使用自动。send功能，但不能让它工作，我希望不必继续使用。display在这种情况下，出于明显的原因。

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

Answer 1

Send方法不安全，当Outlook从外部应用程序自动运行时，Outlook对象模型可能会触发安全提示或给出错误。下面列出了可能的解决方法:

• 创建一个COM外接程序，它处理一个安全的应用程序实例，它不会触发安全提示。
• 使用Outlook构建的底层代码，并且没有安全触发器。或者也可以考虑围绕该API的任何其他第三方包装器，例如Redemption。
• 使用第三方组件来抑制Outlook安全警告。有关更多信息，请参阅Microsoft Outlook的安全管理器。
• 使用组策略对象设置机器。
• 安装任何具有最新更新的防病毒软件。

Answer 2

这是循环遍历列表的一种方法。

来源:使用Excel和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://learn.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