1

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
NVReddy
  • 52
  • 6
  • The relevant code is in `Application_Startup` where you indicate the folder associated with inboxItems. – niton Sep 21 '20 at 13:18
  • Possible duplicate of [Get reference to additional Inbox](https://stackoverflow.com/questions/9076634/get-reference-to-additional-inbox) – niton Sep 21 '20 at 13:18
  • so it means I should mention/declare 20 shared_inboxitems in Application_Startup ? – NVReddy Sep 21 '20 at 13:52
  • 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 Sep 21 '20 at 14:24
  • 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 Sep 22 '20 at 10:57

1 Answers1

1

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("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
niton
  • 8,771
  • 21
  • 32
  • 52
  • Hi Niton, thank you for response, really appreciated and sorry for delayed reply. I tried above code and got error as "Run-Time error '-21472212333 (800401f)'" with code line of "Set sharedInboxItms1 = sharedInbox1.Folders("Inbox").Items" in Application_Startup sub. hence I have changed to Set sharedInboxItms1 = sharedInbox1.Items and got worked. and extension of this I am looking out with Sharemailbox sent items also with same concept. would you please give some hint how this concept. – NVReddy Sep 28 '20 at 12:00
  • To apply the same concept to the Sent folder refer to olFolderSentMail and change "Inbox" to the text you see for the Sent folder. – niton Sep 28 '20 at 16:20
  • Hi niton, thank you for making me understand the concept and the code has been deployed and it is working only if sharedmailbox is active otherwise it is not triggering the events. for example the event is not triggering for sharedmailbox2 if active session is with sharedmailbox1. I am now quite confusing how to trigger events for all the sharedmailboxes(20) even if session is inactive. I am using Outlook 2016 version. – NVReddy Oct 01 '20 at 15:39
  • If these are not already 20 additional accounts in the profile. I suggest you could create another profile. Add some as accounts. https://support.microsoft.com/en-us/office/add-an-email-account-to-outlook-6e27792a-9267-4aa4-8bb6-c84ef146101b. The second profile will look the same as the one you have now but there will be some different functionality. ItemAdd behaviour may change. If not, post another question about this issue. – niton Oct 01 '20 at 20:57
  • Thank you sir, 20 additional accounts already in the profile. But not triggering. Anyhow i will try little more digging in weekend if not i will post other question as you suggested. Thank you so much i learnt a lot with your code....:) – NVReddy Oct 01 '20 at 21:46