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

Question

我们正在尝试将新的邮件项目组件存储到 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

Answer 1

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

Option Explicit

Private WithEvents inboxItms As Items

Private WithEvents sharedInboxItms1 As Items
' ...
Private WithEvents sharedInboxItms20 As Items


Private Sub Application_Startup()

    Dim defaultInbox As Folder

    Dim sharedMailbox1 As Folder
    Dim sharedInbox1 As Folder
    ' ...
    Dim sharedMailbox20 As Folder
    Dim sharedInbox20 As Folder

    Set defaultInbox = Session.GetDefaultFolder(olFolderInbox)
    Set inboxItms = defaultInbox.Items

    Set sharedMailbox1 = Session.Folders("SharedMailbox1@somewhere.com")
    Set sharedInbox1 = sharedMailbox1.Folders("Inbox")

    ' typo fixed
    'Set sharedInboxItms1 = sharedInbox1.Folders("Inbox").Items
    Set sharedInboxItms1 = sharedInbox1.Items
    ' ...
    Set sharedMailbox20 = Session.Folders("SharedMailbox20@somewhere.com")
    Set sharedInbox20 = sharedMailbox20.Folders("Inbox")

    ' typo fixed
    'Set sharedInboxItms20 = sharedInbox20.Folders("Inbox").Items
    Set sharedInboxItms20 = sharedInbox20.Items

End Sub


Private Sub inboxItms_ItemAdd(ByVal Item As Object)
   ' current code for default inbox
End Sub

Private Sub sharedInboxItms1_ItemAdd(ByVal Item As Object)
    inboxItms_ItemAdd Item
End Sub

' ...

Private Sub sharedInboxItms20_ItemAdd(ByVal Item As Object)
     inboxItms_ItemAdd Item
End Sub