Outlook has exhausted all shared resources. Why? - vba

Question

With this bit of VBA code in MS Access I'm getting an error if its executed too often. The only way I've found to clear it is reboot my computer. Any idea why and what can I do?
Public Function HasOutlookAcct(strEmail As String) As Boolean
Dim OutMail As Object
Dim OutApp As OutLook.Application
Dim objNs As OutLook.NameSpace
Dim objAcc As Object
'https://stackoverflow.com/questions/67284852/outlook-vba-select-sender-account-when-new-email-is-created
Set OutApp = CreateObject("Outlook.Application")
Set objNs = OutApp.GetNamespace("MAPI")
For Each objAcc In objNs.Accounts
If objAcc.SmtpAddress = strEmail Then
HasOutlookAcct = True
Exit For
End If
Next
OutApp.Quit
Set objAcc = Nothing
Set objNs = Nothing
End Function

Answer 1

The code looks good. The NameSpace.Accounts property returns an Accounts collection object that represents all the Account objects in the current profile. I don't see any extensive or heavy usage of the Outlook object model, but creating a new Outlook Application instance in the method for checking whether a particular account is configured in Outlook or not is not the best way of using Outlook. Instead, I'd recommend running Outlook once at some point and getting all the configured emails for saving for future usage where necessary.
Also it makes sense to disable all COM add-ins to see whether it helps or not. The problem may be related to any specific COM add-in.

Answer 2

Appears the error is addressed by considering the user.
The assumption, based on my results, is Outlook is not cleaned up completely when the user's instance is closed with outApp.Quit.
When Outlook is open, outApp.Quit is not applied and Outlook remains open at the end.
When Outlook is not open, it is opened in the background and later closed with outApp.Quit.
There is zero or one instance of Outlook at any time.
Option Explicit
Public Function HasOutlookAcct(strEmail As String) As Boolean
'Reference Outlook nn.n Object Library
' Consistent early binding
Dim outApp As Outlook.Application
Dim objNs As Outlook.Namespace
Dim objAcc As Outlook.Account
Dim bCreated As Boolean
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
bCreated = True
Set outApp = CreateObject("Outlook.Application")
End If
Set objNs = outApp.GetNamespace("MAPI")
For Each objAcc In objNs.Accounts
'Debug.Print objAcc.SmtpAddress
If objAcc.SmtpAddress = strEmail Then
HasOutlookAcct = True
Exit For
End If
'Set objAcc = Nothing ' Additional cleanup if needed
Next
If bCreated = True Then ' Outlook object had to be created
outApp.Quit
End If
'Set outApp = Nothing ' Additional cleanup if needed
Set objNs = Nothing
End Function
Private Sub HasOutlookAcct_Test()
Dim x As Boolean
Dim sEmail As String
sEmail = "someone#somewhere.com"
Dim i As Long
For i = 1 To 50
Debug.Print i & ": " & sEmail
x = HasOutlookAcct(sEmail)
Debug.Print " HasOutlookAcct: " & x
DoEvents
Next
Debug.Print "done"
End Sub