创建没有兑换扩展的 MS Outlook OOO Exchange (VBA)？

Question

我正在尝试自动创建一个简单的“外出”，在其中我将根据变量传达消息和日期。

我正在使用的基本代码是：

Sub OutOfOffice()
    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, True
        End If
    Next
End Sub

当我运行它时，OOO 未启用。我在网上读到，为了完成这项工作，我需要启用参考“兑换 Outlook 和 MAPI 库”，但我在 Outlook 参考列表中找不到它。然后我将字符串粘贴到 Chrome 中，发现这个 Redemption 库似乎由 Dimastr.com 所有并授权，因此它不是 Outlook 主包的一部分。

最终目标是在我创建它时编写一个 OOO，其中包含自定义文本和日期。

有没有一种方法可以在不依赖外部提供商的情况下实现这一结果？

Answer 1

如果您改变主意，不想触发任何收到的邮件并自动发送 OOO，请尝试下一种方法：

1. 确保您在 Outlook 中启用了宏并保持打开状态。

2. 复制

   ThisOutlookSession

   代码模块中的下一个代码事件：

Option Explicit

Private WithEvents Items As Outlook.Items 
Private Const boolOOO As Boolean = True

Private Sub Application_Startup()
  Dim olApp As Outlook.Application, objNS As Outlook.NameSpace

  Set olApp = Outlook.Application
  Set objNS = olApp.GetNamespace("MAPI")
  'local Inbox:
  Set Items = objNS.GetDefaultFolder(olFolderInbox).Items 'to trigger the following event
End Sub

Private Sub Items_ItemAdd(ByVal item As Object) 'it triggers each received mail (in InBox):
  Dim Msg As Outlook.MailItem
  If TypeName(item) = "MailItem" Then
    Set Msg = item
    If boolOOO Then SendOutOfOffice Msg 'call the Sub able to reply
  End If
End Sub

Private Sub SendOutOfOffice(Msg As Outlook.MailItem)

  Dim strBody As String
  strBody = "Hi," & vbCrLf & vbCrLf & "I will be in vacation starting from 3rd of September until 18th of September 2023" & vbCrLf & _
            "For assistance you may contact [email protected]." & vbCrLf & vbCrLf & _
            "John Doe"
  'MsgBox Msg.Body: Exit Sub
  
  On Error GoTo ErrorHandler
  Dim olOutMail As Outlook.MailItem
    With Msg
        Set olOutMail = Msg.Reply
        With olOutMail
            .Body = strBody
            .Send
        End With
        Set olOutMail = Nothing
    End With
    Exit Sub
ErrorHandler:
  Debug.Print Err.Number & ": " & Err.Description
  Err.Clear
End Sub

要测试它，请手动运行

Application_Startup

。 Outlook 启动时它将自动运行。

如果你想停止OOO，只需将

boolOOO

的值更改为

False

即可。

正如我在上面的评论中所说，可以通过发送具有特定标记（主题、正文、来自特定帐户等）的邮件来调整代码以远程启动/停止 OOO。