经常验证 Outlook 可用性：Outlook 已耗尽所有共享资源

Question

使用 MS Access 中的此 VBA 代码，如果执行得太频繁，我会收到错误。我发现清除它的唯一方法是重新启动计算机。

Outlook 已耗尽所有共享资源...

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

代码看起来不错。 NameSpace.Accounts 属性返回一个

Accounts

集合对象，表示当前配置文件中的所有

Account

对象。我没有看到 Outlook 对象模型有任何广泛或大量使用，但在检查 Outlook 中是否配置特定帐户的方法中创建新的 Outlook 应用程序实例并不是使用 Outlook 的最佳方法。相反，我建议在某个时候运行 Outlook 一次，并获取所有配置的电子邮件以保存以供将来在必要时使用。

禁用所有 COM 加载项也很有意义，看看是否有帮助。该问题可能与任何特定的 COM 加载项有关。

Answer 2

看来错误已通过考虑用户来解决。

根据我的结果，假设是当用户使用

outApp.Quit

关闭用户实例时，Outlook 并未完全清理。

当 Outlook 打开时，

outApp.Quit

不会应用，Outlook 最终保持打开状态。

当 Outlook 未打开时，它会在后台打开，然后用

outApp.Quit

关闭。

任何时候都有零个或一个 Outlook 实例。

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