如何通过从Outlook联系人列表中获取他们的电子邮件地址来发送电子邮件给A列中的人员姓名？

Question

我想发送电子邮件到A列中列出的名称，但我没有他们的电子邮件地址。该电子邮件地址在Outlook联系人中。我可以在B列显示他们的电子邮件，但我不想这样做。我想查找电子邮件地址并将其附加到电子邮件中的“收件人”字段。现在的样子是，它只会将列A中最后一个人的电子邮件地址附加到列A中其他人的所有电子邮件中，如图中所示。 “A”列中的所有人都收到了To字段中最后一个人的相同电子邮件地址。

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 

Answer 1

创建每个邮件您覆盖ToField之前。

For Each AddressEntry In AddressList.AddressEntries 
    If AddressEntry.Name = AddressName Then 
     'c.Offset(0, 1).Value = AddressEntry.Address 
     ToField = AddressEntry.Address 
     'MsgBox ToField 

     Set OutMail = o.CreateItem(0) 

     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 

     Set OutMail = Nothing    

     Exit For 
    End If 
Next AddressEntry 

Answer 2

永远不会遍历地址簿容器中的所有项目。如果名称可以解析为联系人，则只需设置MailItem.To属性 - 发送邮件时，Outlook将把名称解析为地址。如果您想在发送邮件之前这样做，或者您确实需要电子邮件地址，请致电Application.Session.CreateRecipient - 它将返回收件人对象的实例。致电Recipient.Resolve并阅读Recipient.Address财产。如果名称无法解析（如果找不到名称或名称不明确），Recipient.Resolve将引发异常。

Answer 3

考虑这样做。

In column A : Names of the people 
In column B : E-mail addresses 
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files) 

通过“工作表Sheet1”每一行和宏将循环如果在C列在B列 和文件名（S）一个E-mail地址位：Z它会创建一个邮件与此信息并发送它。

Sub Send_Files() 
'Working in Excel 2000-2016 
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm 
    Dim OutApp As Object 
    Dim OutMail As Object 
    Dim sh As Worksheet 
    Dim cell As Range 
    Dim FileCell As Range 
    Dim rng As Range 

    With Application 
     .EnableEvents = False 
     .ScreenUpdating = False 
    End With 

    Set sh = Sheets("Sheet1") 

    Set OutApp = CreateObject("Outlook.Application") 

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants) 

     'Enter the path/file names in the C:Z column in each row 
     Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1") 

     If cell.Value Like "?*@?*.?*" And _ 
      Application.WorksheetFunction.CountA(rng) > 0 Then 
      Set OutMail = OutApp.CreateItem(0) 

      With OutMail 
       .to = cell.Value 
       .Subject = "Testfile" 
       .Body = "Hi " & cell.Offset(0, -1).Value 

       For Each FileCell In rng.SpecialCells(xlCellTypeConstants) 
        If Trim(FileCell) <> "" Then 
         If Dir(FileCell.Value) <> "" Then 
          .Attachments.Add FileCell.Value 
         End If 
        End If 
       Next FileCell 

       .Send 'Or use .Display 
      End With 

      Set OutMail = Nothing 
     End If 
    Next cell 

    Set OutApp = Nothing 
    With Application 
     .EnableEvents = True 
     .ScreenUpdating = True 
    End With 
End Sub 

https://www.rondebruin.nl/win/s1/outlook/amail6.htm