如果 Outlook 中的联系人不存在，则运行时错误答案

【问题标题】：Runtime error if contact in Outlook doesn't exist如果 Outlook 中的联系人不存在，则运行时错误
【发布时间】：2018-10-04 00:40:28
【问题描述】：

当我完成一项工作时，我会将其通过电子邮件发送给某些人。这取决于谁得到它。

如果列表中的任何人离开、换工作或更改电子邮件，代码会错误提示

运行时错误 -2147467259(80004005)，Outlook 无法识别一个或多个名称

如果我手动复制列表中的电子邮件地址并将它们弹出到 Outlook 中并发送，我会收到一封电子邮件，说用户不存在或已更改。

我尝试过 On Error Resume Next 和 On Error Goto。我从参考资料中添加了 MS Outlook 14.0 对象库、SharePoint Social Provider、Social Provider Extensibility 和 Outlook View 控件。

.send 上的代码错误

Sub EMailer()

Application.ScreenUpdating = False

strfilepath = "\\DFZ70069\Data\199711009\workgroup\Res Plan Team\Performance Management\Specialised Reporting\Debit & Credit Reporting\Masters\Sent Reports\"

strArea = "Recipients" '..........................................................................................

    'Get list of recipients for email
For Each cell In Worksheets("EMails").Range(sRange)
If cell.Value = "" Then GoTo Continue
strmaillist = strmaillist & cell.Value + ";"
Continue:
Next

[B1].Value = strmaillist

If bMyEmail = True Then
strmaillist = strmaillist & MyEmailAddress
End If

    'Display email list
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 1
Select Case InfoBox.Popup("Sending " & sReportName & " emails to " & vbNewLine & strArea, _
AckTime, "Message Box", 0)
Case 1, -1
End Select

    'SEND EMAIL

    'set up Body of email............
strbody = "Please find attached " & sReportName & " Report " & " _" & strDate & vbLf & vbLf & _
strComments & vbLf & _
strComments2 & vbLf & _
"" & vbLf & _
eMailName & vbLf & _
"MI & Performance Reporting Team" & vbLf & _
sline2 & vbLf & _
sline3 & vbLf & vbLf & _
sLine4

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

    With OutMail
        .to = strmaillist
        .CC = ""
        .BCC = ""
        .Subject = sReportName & " Report " & strDate
        .HTMLBody = "Set to HTML" & vbLf & vbLf & ""
        .Body = strbody
        .Attachments.Add (strfilepath & sTemplateName)
        .send ' bugs out here
    End With

Set OutMail = Nothing
Set OutApp = Nothing

ThisWorkbook.Activate
Sheets("Sheet1").Select
Application.ScreenUpdating = True: Application.ScreenUpdating = False
Sheets("Sheet1").Select
Range(sRange2).Value = sConclusion '.
Application.ScreenUpdating = True: Application.ScreenUpdating = False

End Sub

【问题讨论】：

标签： vba excel outlook

【解决方案1】：

您可以尝试在发送前检查收件人的有效性，方法是使用Recipient 对象的.Resolve 方法。只有有效的收件人才能保留在邮件的收件人列表中。

你可以试试这个：

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

With OutMail
  .Subject = sReportName & " Report " & strDate
  .HTMLBody = "Set to HTML" & vbLf & vbLf & ""
  .Body = strbody
  .Attachments.Add (strfilepath & sTemplateName)

  For Each cell In Worksheets("EMails").Range(sRange)
    If cell.Value <> "" Then
      set r = .Recipients.Add(cell.value)
      If Not r.Resolve then r.Delete '<~~ Removes invalid recipients
    End If
  Next
  .send
End With

【讨论】：