我想发送电子邮件到A列中列出的名称,但我没有他们的电子邮件地址。该电子邮件地址在Outlook联系人中。我可以在B列显示他们的电子邮件,但我不想这样做。我想查找电子邮件地址并将其附加到电子邮件中的“收件人”字段。现在的样子是,它只会将列A中最后一个人的电子邮件地址附加到列A中其他人的所有电子邮件中,如图中所示。 “A”列中的所有人都收到了To字段中最后一个人的相同电子邮件地址。 如何通过从Outlook联系人列表中获取他们的电子邮件地址来发送电子邮件给A列中的人员姓名?
Option Explicit
Sub GetAddressesAndSendEmail()
Sheet10.Select
Dim o, AddressList, AddressEntry
Dim ToField As String
Dim c As range, r As range, AddressName As String
Set o = CreateObject("Outlook.Application")
Set AddressList = o.Session.AddressLists("Contacts")
Set r = Sheet10.range("A1", range("A1").End(xlDown))
For Each c In r
AddressName = c.Value
For Each AddressEntry In AddressList.AddressEntries
If AddressEntry.Name = AddressName Then
'c.Offset(0, 1).Value = AddressEntry.Address
ToField = AddressEntry.Address
'MsgBox ToField
Exit For
End If
Next AddressEntry
Next c
Dim OutApp As Object
Dim OutMail As Object
Dim cell As range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
If LCase(Cells(cell.Row, "D").Value) <> "" Then
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ToField
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
.Attachments.Add ("C:\" & Cells(cell.Row, "D").Value & ".txt")
'.Send
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
注释掉对错误转到清理。用结果编辑你的问题。 – niton
我做到了,没有发生任何事。发生同样的问题。 – cookiemonster
看看这个链接关于您的问题https://stackoverflow.com/questions/10049419/how-to-access-contact-groups-in-excel-vba – Mitch