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

时间:2016-01-14 10:06:35

标签: excel vba excel-vba outlook

当我完成一项工作后,我会通过电子邮件发送给某些人。这取决于获得它的工作。

如果列表中的任何人离开,更改工作或更改了电子邮件,则代码将错误地说

  

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

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

我尝试过On Error Resume Next和On Error Goto。我从参考资料中添加了MS Outlook 14.0对象库,SharePoint社交提供程序,社交提供程序可扩展性和Outlook视图控件。

代码在.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

1 个答案:

答案 0 :(得分:0)

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

你可以试试这个:

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