0
votes

We are trying to store new mail item components into excel and assign tkt id, have tried doing it with single shared mailbox and succeeded but we want to implement same for 20 shared mail boxes. how can outlook vba event/trigger identify as soon as new email arrives to one of the 20 shared mail boxes.

this is code which will only work for default inbox:

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
1
The relevant code is in Application_Startup where you indicate the folder associated with inboxItems.niton
Possible duplicate of Get reference to additional Inboxniton
so it means I should mention/declare 20 shared_inboxitems in Application_Startup ?NVReddy
Yes 20 in startup. Call, do not duplicate, the code in the post in each of Private Sub inboxItems1_ItemAdd(ByVal Item As Object) ... Private Sub inboxItems20_ItemAdd(ByVal Item As Object.niton
I have tried do it but I am bit confused, would you please give example. and to notify that the sub link is not working which was provided by brettdj for handling different mailboxes.NVReddy

1 Answers

0
votes

If the 20 shared mailboxes are in the navigation pane.

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("[email protected]")
    Set sharedInbox1 = sharedMailbox1.Folders("Inbox")

    ' typo fixed
    'Set sharedInboxItms1 = sharedInbox1.Folders("Inbox").Items
    Set sharedInboxItms1 = sharedInbox1.Items
    ' ...
    Set sharedMailbox20 = Session.Folders("[email protected]")
    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