Outlook VBA设置自动回复状态后不生效的问题求助

问题描述 #

我使用以下Outlook VBA代码检查和设置自动回复（Out of Office）状态：

Sub CheckStatus()
    MsgBox Check_Out_Of_Office()
End Sub

Sub ActivateStatus()
    OutOfOffice True
End Sub

Function Check_Out_Of_Office() As Boolean
    'Checks to see if out of office is already enabled
    On Error GoTo eh
    Dim oNS As Outlook.NameSpace
    Dim oStores As Outlook.Stores
    Dim oStr As Outlook.Store
    Dim oPrp As Outlook.PropertyAccessor
    Set oNS = Outlook.GetNamespace("MAPI")
    Set oStores = oNS.Stores
    For Each oStr In oStores
    If oStr.ExchangeStoreType = olPrimaryExchangeMailbox Then
    Set oPrp = oStr.PropertyAccessor
    Check_Out_Of_Office = oPrp.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x661D000B")
    End If
    Next
    Exit Function
eh:
        MsgBox "The following error occurred: " & Err.Description
End Function


Sub OutOfOffice(bolState As Boolean)
'Calling this with a state of True enables out of office and calling it with a state of False disables out of office
On Error GoTo eh
    Const PR_OOF_STATE = "http://schemas.microsoft.com/mapi/proptag/0x661D000B"
    Dim olkIS As Outlook.Store, olkPA As Outlook.PropertyAccessor
    For Each olkIS In Session.Stores
        If olkIS.ExchangeStoreType = olPrimaryExchangeMailbox Then
            Set olkPA = olkIS.PropertyAccessor
            olkPA.SetProperty PR_OOF_STATE, bolState
        End If
    Next
    Set olkIS = Nothing
    Set olkPA = Nothing
Exit Sub
eh:
    MsgBox "The following error occurred: " & Err.Description
End Sub

手动开启自动回复后，VBA检查状态能得到预期值；但通过VBA将状态设为True后，VBA检测显示已开启，Outlook界面却未显示自动回复激活，且外部账户发送邮件收不到自动回复。我使用Microsoft 365的Exchange账户，不想安装Redemption等外部库，寻求解决办法。

解决办法 #

直接修改PR_OOF_STATE仅修改了本地缓存状态，未同步到Exchange服务器，且Outlook界面不会自动刷新该状态。以下两种无需第三方库的解决方案：

方法1：使用Exchange Web Services (EWS) #

通过EWS直接操作Exchange服务器的OOF设置，需先添加EWS引用（VBA编辑器→工具→引用→勾选Microsoft Exchange Web Services，缺失则需安装EWS Managed API）。示例代码：

Sub SetOOFUsingEWS(bolState As Boolean)
    Dim service As New ExchangeService
    Dim oofSettings As New OofSettings
    
    ' 配置EWS服务
    service.Credentials = New WebCredentials(Application.Session.CurrentUser.Address, "你的账户密码")
    service.AutodiscoverUrl Application.Session.CurrentUser.Address, AddressOf RedirectionUrlValidationCallback
    
    ' 设置OOF参数
    oofSettings.State = IIf(bolState, OofState.Enabled, OofState.Disabled)
    oofSettings.InternalReply.Message = New MessageBody("内部自动回复内容")
    oofSettings.ExternalReply.Message = New MessageBody("外部自动回复内容")
    
    ' 同步到服务器
    service.SetUserOofSettings(Application.Session.CurrentUser.Address, oofSettings)
End Sub

Function RedirectionUrlValidationCallback(ByVal redirectionUrl As String) As Boolean
    ' 允许自动发现重定向
    RedirectionUrlValidationCallback = True
End Function

方法2：强制同步+界面刷新 #

修改属性后强制Outlook同步数据到服务器，并刷新界面：

Sub OutOfOffice(bolState As Boolean)
    Const PR_OOF_STATE = "http://schemas.microsoft.com/mapi/proptag/0x661D000B"
    Dim olkIS As Outlook.Store, olkPA As Outlook.PropertyAccessor
    
    On Error GoTo eh
    For Each olkIS In Session.Stores
        If olkIS.ExchangeStoreType = olPrimaryExchangeMailbox Then
            Set olkPA = olkIS.PropertyAccessor
            olkPA.SetProperty PR_OOF_STATE, bolState
            ' 强制同步当前邮箱
            olkIS.SendAndReceive True
        End If
    Next
    
    ' 刷新Outlook界面
    Application.ActiveExplorer.CurrentFolder = Application.ActiveExplorer.CurrentFolder
    
    Set olkIS = Nothing
    Set olkPA = Nothing
Exit Sub
eh:
    MsgBox "发生以下错误: " & Err.Description
End Sub

注意：方法2的可靠性依赖Exchange同步机制，部分环境下可能无效，优先推荐EWS方案。

内容的提问来源于stack exchange，提问作者A.M