Vba 是否可以通过OUTLOOK触发器/事件识别共享邮箱接收到的新电子邮件？

我们正在尝试将新的邮件项目组件存储到excel中并分配tkt id，尝试使用单个共享邮箱进行此操作并成功，但我们希望为20个共享邮箱实现相同的功能。新电子邮件到达20个共享邮箱之一时，outlook vba事件/触发器如何识别

这是仅适用于默认收件箱的代码：

Private Sub inboxItems_ItemAdd(ByVal Item As Object)

Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
If TypeName(Item) = "MailItem" Then
        Dim cn As Object
        Dim sCon As String
        Dim sSQL As String
        Dim bytHasAttachment As String
        Dim strAddress As String
        Dim objSender, exUser

        Dim olRecipient As Outlook.Recipient
        Dim strToEmails, strCcEmails, strBCcEmails As String

        For Each olRecipient In Item.Recipients
            Dim mail As String
            If olRecipient.AddressEntry Is Nothing Then
                    mail = olRecipient.Address
            ElseIf olRecipient.AddressEntry.GetExchangeUser Is Nothing Then
                    mail = olRecipient.Address
            Else
                    mail = olRecipient.AddressEntry.GetExchangeUser.PrimarySmtpAddress
            End If
    
            If olRecipient.Type = Outlook.OlMailRecipientType.olTo Then
                    strToEmails = strToEmails + mail & ";"
            ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olCC Then
                    strCcEmails = strCcEmails + mail & ";"
            ElseIf olRecipient.Type = Outlook.OlMailRecipientType.olBCC Then
                    strBCcEmails = strBCcEmails + mail & ";"
            End If
        Next

        With Item
            If Item.Attachments.Count > 0 Then
                    bytHasAttachment = 1
            Else
                    bytHasAttachment = 0
            End If
        End With

    'On Error Resume Next 'PropertyAccessor can raise an exception if a property is not found
        If Item.SenderEmailType = "SMTP" Then
            strAddress = Item.SenderEmailAddress
        Else
            'read PidTagSenderSmtpAddress
        strAddress = Item.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")
            If Len(strAddress) = 0 Then
                Set objSender = Item.Sender
                If Not (objSender Is Nothing) Then
                'read PR_SMTP_ADDRESS_W
                    strAddress = objSender.PropertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x39FE001F")
                    If Len(strAddress) = 0 Then
                            Set exUser = objSender.GetExchangeUser
                            If Not (exUser Is Nothing) Then
                                strAddress = exUser.PrimarySmtpAddress
                            End If
                    End If
                End If
            End If
        End If

    On Error GoTo ErrorHandler

    Set cn = CreateObject("ADODB.Connection")
    sCon = "Driver=MySQL ODBC 8.0 ANSI Driver;SERVER=localhost;UID=root;PWD={Platinum@123};DATABASE=liva_dev_gm;PORT=3306;COLUMN_SIZE_S32=1;DFLT_BIGINT_BIND_STR=1"
    cn.Open sCon

    sSQL = "INSERT INTO tbl_gmna_emailmaster_inbox (eMail_Icon, eMail_MessageID, eMail_Folder, eMail_Act_Subject, eMail_From, eMail_TO, eMail_CC, " & _
       "eMail_BCC, eMail_Body, eMail_DateReceived, eMail_TimeReceived, eMail_Anti_Post_Meridiem, eMail_Importance, eMail_HasAttachment) " & _
       "VALUES (""" & Item.MessageClass & """, " & _
       """" & Item.EntryID & """, " & _
       """Inbox""" & ", " & _
       """" & Item.Subject & """, " & _
       """" & strAddress & """, " & _
       """" & strToEmails & """, " & _
       """" & strCcEmails & """, " & _
       """" & strBCcEmails & """, " & _
       """" & Item.Body & """, " & "'" & Format(Item.ReceivedTime, "YYYY-MM-DD") & "', " & "'" & Format(Item.ReceivedTime, "hh:mm:ss") & "', " & "'" & Format(Item.ReceivedTime, "am/pm") & "', " & "'" & Item.Importance & "', " & "'" & bytHasAttachment & "')"
    cn.Execute sSQL
End If
ExitNewItem:
    bytHasAttachment = ""
    Exit Sub
ErrorHandler:
        MsgBox Err.Number & " - " & Err.Description
        Resume ExitNewItem
End Sub

---

如果导航窗格中有20个共享邮箱

选项显式
以Oxitms中的事件作为项目的私有
Private，将事件共享到BoxITMS1作为项目
' ...
Private与Events sharedInboxItms20作为项目
私有子应用程序_启动（）
将默认收件箱设置为文件夹
Dim sharedMailbox1作为文件夹
Dim sharedInbox1作为文件夹
' ...
Dim sharedMailbox20作为文件夹
Dim sharedInbox20作为文件夹
设置defaultInbox=Session.GetDefaultFolder（olFolderInbox）
设置inboxItms=defaultInbox.Items
设置sharedMailbox1=Session.Folders（“SharedMailbox1@somewhere.com")
设置sharedInbox1=sharedMailbox1.Folders（“收件箱”）
“拼写错误修复
'设置sharedInboxItms1=sharedInbox1.Folders（“收件箱”）.Items
设置sharedInboxItms1=sharedInbox1.Items
' ...
设置sharedMailbox20=Session.Folders（“SharedMailbox20@somewhere.com")
设置sharedInbox20=sharedMailbox20.Folders（“收件箱”）
“拼写错误修复
'设置sharedInboxItms20=sharedInbox20.Folders（“收件箱”）.Items
设置sharedInboxItms20=sharedInbox20.Items
端接头
私有子inboxItms_ItemAdd（ByVal项作为对象）
'默认收件箱的当前代码
端接头
私有子共享dinboxitms1_ItemAdd（ByVal项作为对象）
inboxItms_项目添加项目
端接头
' ...
私有子共享dinboxitms20_ItemAdd（ByVal项作为对象）
inboxItms_项目添加项目
端接头

相关代码位于

应用程序启动

中，您可以在其中指明与inboxItems关联的文件夹。可能存在重复项，因此这意味着我应该在应用程序启动中提及/声明20个共享的inboxItems？是，在启动中为20个。调用，不要重复，

Private Sub inboxItems1\u ItemAdd（ByVal Item As Object）中的每个帖子中的代码。。。私有子收件箱20\u项目添加（ByVal项目作为对象

。我已经尝试过了，但我有点困惑，请举例说明。并通知BRETDJ提供的用于处理不同邮箱的子链接不起作用。您好，尼顿，感谢您的回复，非常感谢，并对延迟回复表示歉意。我尝试了上述代码，但得到了错误信息“运行时错误”-21472212333（800401f）”，代码行为“Set-sharedInboxItms1=sharedInbox1.Folders（“收件箱”）.Items“在Application_Startup sub.中，因此我已更改为设置sharedInboxItms1=sharedInbox1.Items，并已开始工作。我正在查看的Sharemailbox发送的邮件的扩展也具有相同的概念。请您给出一些提示，说明如何使用此概念。若要将相同的概念应用于发送的文件夹，请参阅olFolderSentMail并更改“收件箱”您好，尼顿，谢谢您让我理解这个概念，代码已经部署，它只有在sharedmailbox处于活动状态时才能工作，否则它不会触发事件。例如，如果活动会话与sharedmailbox1在一起，sharedmailbox2的事件就不会触发。我现在很困惑如何触发所有SharedMailbox的事件（20）即使会话处于非活动状态。我正在使用Outlook 2016版本。如果配置文件中还没有20个其他帐户，我建议您创建另一个配置文件。添加一些帐户。第二个配置文件看起来与您现在拥有的配置文件相同，但会有一些不同的功能。ItemAdd行为可能会改变。如果没有，请发布关于这个问题的其他问题。谢谢你，先生，档案中已经有20个额外的帐户。但是没有触发。无论如何，我会在周末尝试更多的挖掘，如果没有的话，我会按照你的建议发布其他问题。非常感谢你，我从你的代码中学到了很多……）