Имеем следующий код
On Error Resume Next
Dim myOlApp As Outlook.Application
Set myOlApp = New Outlook.Application
On Error GoTo 0
If myOlApp Is Nothing Then
Set myOlApp = CreateObject("Outlook.Application")
'Set myOlApp = GetObject(, "Outlook.Application") тоже не работает
End If
Dim myNameSpace As Outlook.NameSpace
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Dim myFolder As Outlook.MAPIFolder
Set myFolder = myNameSpace.GetDefaultFolder(olFolderContacts)
For i = 1 To myFolder.Items.Count
'какие-то действия
Next
Set myFolder = Nothing
Set myNameSpace = Nothing
myOlApp.Quit
Set myOlApp = Nothing
Проблема в том что аутлук не выгружается и при повторном запуске невозможно ни создать новый экземпляр аутлука ни прицепиться к существующему.