Excel 2013 Outlook 收件人解析失败

Question

I have the following code that worked fine in Excel 2007 but fails in Excel 2013.

Dim lappOutlook As Outlook.Application
Dim lappNamespace As Outlook.Namespace
Dim lappRecipient As Outlook.RECIPIENT

Set lappOutlook = CreateObject("Outlook.Application")
Set lappNamespace = lappOutlook.GetNamespace("MAPI")
Set lappRecipient = lappNamespace.CreateRecipient("smithj1")

lappRecipient.Resolve

What I'm doing is parsing emails from a folder in my inbox. However, I need to resolve the recipient but that fails. The code you see starts out the sub and the remainder of the code follows the resolve method.

The error returned is:

Run-time error '287': Application-defined or object-defined error

The error help really does not provide any useful information. Especially since this worked perfectly in Excel 2007 but now fails after an "upgrade" to Excel 2013.

I have tried "smithj1@company.org" and "John Smith" and "John A. Smith", etc. (those are not the real name) but nothing works. When I copied this to a laptop that still had Office 2007 on it, the code ran perfectly. Within the hour, the laptop was "upgraded" automatically to Office 2013 and the code failed.

Any help would be greatly appreciated.

Answer 1

Try waiting to see if there is a delayed response.

Private Sub openOutlook2()

Dim lappOutlook As Outlook.Application
Dim lappNamespace As Outlook.Namespace
Dim lappRecipient As Outlook.Recipient

Dim strAcc As String

Dim maxTries As Long
Dim errCount As Long

Set lappOutlook = CreateObject("Outlook.Application")
Set lappNamespace = lappOutlook.GetNamespace("MAPI")

strAcc = "smithj1"
Set lappRecipient = lappNamespace.CreateRecipient(strAcc)

maxTries = 2000

On Error GoTo errorResume

Retry:

    DoEvents

    ' For testing error logic. No error with my Excel 2013 Outlook 2013 setup.
    ' Should normally be commented out
    'Err.Raise 287

    lappRecipient.Resolve

On Error GoTo 0

If lappRecipient.Resolved Then
     Debug.Print strAcc & " resolved."
     MsgBox strAcc & "  resolved."
Else
    Debug.Print strAcc & " not resolved."
    MsgBox "No error: " & strAcc & " not resolved."
End If

ExitRoutine:

    Set lappOutlook = Nothing
    Set lappNamespace = Nothing
    Set lappRecipient = Nothing

    Debug.Print "Done."

    Exit Sub

errorResume:

    errCount = errCount + 1

    ' Try until Outlook responds
    If errCount > maxTries Then

        ' Check if Outlook is there and Resolve is the issue
        lappNamespace.GetDefaultFolder(olFolderInbox).Display
        GoTo ExitRoutine

    End If

    Debug.Print errCount & " - " & Err.Number & ": " & Err.Description
    Resume Retry

End Sub