Outlook has exhausted all shared resources. Why?-CodePudding

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

CodePudding user response：

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.

CodePudding user response：

Appears the error is addressed by considering the user.

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 = "[email protected]"

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