Excel 2013 Перспективы получателей Resolve не удается

Question

У меня есть следующий код, который работал хорошо в Excel 2007, но не в 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 

Что я делаю разбор писем из папки в почтовом ящике. Однако мне нужно разрешить получателя, но это не удается. Код, который вы видите, начинается с суб, а оставшаяся часть кода следует за методом разрешения.

Обнаружена ошибка:

Ошибка выполнения «287»: приложения или объекта определенные ошибки

помощь ошибка действительно не дает никакой полезной информации. Тем более, что это отлично работало в Excel 2007, но теперь выходит из строя после «обновления» до Excel 2013 года.

Я пробовал «smithj1@company.org» и «John Smith» и «John A. Smith» и т. Д. (это не настоящее имя), но ничего не работает. Когда я скопировал это на ноутбук, на котором все еще был Office 2007, код работал отлично. В течение часа ноутбук автоматически обновлялся до Office 2013, и код не удался.

Любая помощь была бы принята с благодарностью.

Answer 1

Постарайтесь, чтобы увидеть, есть ли отложенный ответ.

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