如何为来自共享收件箱的新邮件触发 Outlook 宏答案

【问题标题】：how to trigger a outlook macro for new mails from shared inbox如何为来自共享收件箱的新邮件触发 Outlook 宏
【发布时间】：2020-09-05 09:09:02
【问题描述】：

此代码非常适用于普通收件箱，但是如何更改代码以从共享邮箱（xxx@mail .com).folder(收件箱)

如何修改此代码以从特定的共享邮箱“收件箱”触发

Public WithEvents xlItems As Outlook.Items
        Private Sub Application_Startup()
        Set xlItems = Session.GetDefaultFolder(olFolderInbox).Items
        End Sub

完整代码：

Public WithEvents xlItems As Outlook.Items
    Private Sub Application_Startup()
    Set xlItems = Session.GetDefaultFolder(olFolderInbox).Items
    End Sub
    Private Sub xlItems_ItemAdd(ByVal objItem As Object)
    Dim xlReply As MailItem
    Dim xStr As String
    If objItem.Class <> olMail Then Exit Sub
    Set xlReply = objItem.Reply
    With xlReply
         xStr = "<p>" & "Hi Team, Acknowledging that we have received the Job. Thank you!" & "</p>"
         .HTMLBody = xStr & .HTMLBody
         .Send
    End With
End Sub

我尝试修改代码，但没有成功

Option Explicit
Private WithEvents olInboxItems As Items
  Dim objNS As NameSpace
  Set objNS = Application.Session
  ' instantiate objects declared WithEvents
  Set olInboxItems = objNS.Folders("xxxxxxxx@gmail.com").Folders("Inbox").Items
  Set objNS = Nothing
End Sub

Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
Dim xlReply As MailItem
Dim xStr As String
If objItem.Class <> olMail Then Exit Sub
Set xlReply = objItem.Reply
With xlReply
     xStr = "<p>" & "Hi Team, Acknowledging that we have received the Job. Thank you!" & "</p>"
     .HTMLBody = xStr & .HTMLBody
     .Send
End Sub

【问题讨论】：

发帖时描述您看到的任何问题。在修改后的代码中，If objItem.Class <> olMail Then 应该有一个错误，因为objItem 不存在。修改后的代码缺少Private Sub Application_Startup()。直接从编辑器中复制代码。
我试过了，但我不知道 Niton 的代码，请你解决这个问题。 完整代码中提到的代码可以正常工作。当我在修改下包含共享文件夹中的外观时，我遇到了问题
此外，如果我包含“Private Sub Application_Startup()”，它也会触发确认邮件以进行回复并转发邮件。如何限制这些。

标签： vba outlook

【解决方案1】：

这应该比在主题中检查“Re:”和“Fw:”更可靠。

在这个 Outlook 会话中

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Public WithEvents olItems As Items

Private Sub Application_Startup()
    
    Set olItems = Session.Folders("xxxx@xxx.com").Folders("Inbox").Items
    
End Sub

Private Sub olItems_ItemAdd(ByVal Item As Object)

    Dim olReply As MailItem
 
    If Item.Class = olMail Then
        
        If Len(Item.ConversationIndex) > 44 Then
            Exit Sub
        
        Else
        
            Set olReply = Item.reply
    
            With olReply
                .Body = "Reply to first email."
                .Display
            End With
        
        End If
    
    End If
    
End Sub

【讨论】：

感谢您的帮助 Niton，谢谢。此代码完美运行。

【解决方案2】：

我终于自己想出了代码。但它会为所有电子邮件发送邮件，包括（RE 和 FWD）

Public WithEvents olItems As Outlook.Items
Private Sub Application_Startup()
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
' default local Inbox
Set olItems = objNS.Folders("xxxx@xxx.com").Folders("Inbox").Items

End Sub
Private Sub olItems_ItemAdd(ByVal Item As Object)
    Dim olReply As MailItem
 
    If Item.Class = olMail Then
       Set olReply = Item.Reply
    Else
       Exit Sub
    End If
 
    With olReply
         'Type Your Own Auto Reply
         'Change "John Smith" to Your Own Name
         .Body = "This is a test auto reply." & vbCrLf & vbCrLf & "-------Original Message-------" & vbCrLf & "From: " & Item.Sender & "[mailto: " & Item.SenderEmailAddress & "]" & vbCrLf & "Sent: " & Item.ReceivedTime & vbCrLf & "To: YourName" & vbCrLf & "Subject: " & Item.Subject & vbCrLf & Item.Body
         .Send
    End With
End Sub

【讨论】：

【解决方案3】：

这是原始/直观的版本。
主题必须保持不变且为英文。

在这个 Outlook 会话中

Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
' If desperate declare as Variant

Public WithEvents olItems As Items

Private Sub Application_Startup()

    Dim objNS As namespace
    
    Set objNS = GetNamespace("MAPI")
    Set olItems = objNS.Folders("xxxx@xxx.com").Folders("Inbox").Items
    
End Sub

Private Sub olItems_ItemAdd(ByVal Item As Object)

    Dim olReply As MailItem
 
    If Item.Class = olMail Then
        
        If Left(UCase(Item.Subject), 4) = UCase("Re: ") Or _
           Left(UCase(Item.Subject), 4) = UCase("Fw: ") Then
            Exit Sub
        
        Else
        
            Set olReply = Item.reply
    
            With olReply
                .Body = "Reply to first email."
                .Display
            End With
        
        End If
    
    End If
    
End Sub

【讨论】：