Question

我有以下代码，可让我准备一封准备发送的电子邮件：

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .To = ThisWorkbook.Sheets("Users").Range("A1").Value
    .CC = ""
    .BCC = ""
    .Importance = 2
    .Subject = "[ACTION REQUIRED] Format(Date, "YYYYMMDD")"
    .HTMLBody = "some_body"
    .Display
End With

这是Users表：

用户
Johnson，Jerry
Mullen，Carl
Mullen，Carl
Mullen，Carl
Terry，Mark
卡洛斯，胡安

我需要创建一个允许我准备电子邮件的宏，但我的主要问题是我不知道如何使用Users表中的数据添加收件人。我当前的代码不允许我附加除字符串值之外的任何内容（直接键入，或者我可能做错了）。我还需要它不附加重复的名称。

Answer 1

以下代码假定您拥有用户＆＃39;您的Outlook联系人列表中的名称，以及它们位于单元格A2和向下，但该范围可以更改。

Sub test()
Dim users As New Collection
Dim usrRng As Range
Dim recipients As String

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set usrRng = Range("A2", Range("A2").End(xlDown))

Application.ScreenUpdating = False

On Error Resume Next
For Each cell In usrRng
    users.Add cell.Value, cell.Value
Next cell
On Error GoTo 0



For Each usrName In users
    recipients = recipients & usrName & "; "
Next usrName


With OutMail
    .To = recipients
    .CC = ""
    .BCC = ""
    .Importance = 2
    .Subject = "[ACTION REQUIRED] " & Format(Date, "YYYYMMDD")
    .HTMLBody = "some_body"
    .Display
End With

Application.ScreenUpdating = True

End Sub

这样做是因为它将每个名称都放在A2和向下的范围内，并将其添加到集合中，跳过重复项。

然后我们创建一个字符串，它将由我们刚添加到集合中的每个名称组成，用＆＃34 ;;＆＃34;分隔每个名称。然后我们将该新字符串作为消息的接收者传递给OutMail对象。

当显示新邮件时，将无法识别名称，但如果按发送，则应将邮件发送给正确的人，假设您没有多个具有相同名称的联系人。

使用工作表中的范围附加收件人

1 个答案: