Outlook Shared mailbox - new mail triggers macro

[charlests]

Hi,

My requirement is, when i receive a new mail in outlook, it should trigger a macro which saves the new mail info (Sender address, date received, subject etc..) in an excel sheet. I have a macro code which does just that, but it only works for personal mailbox. I want to mimic the same steps for shared mailbox. Here is the code which works perfectly fine for personal mailbox,

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)

Dim varArray As Variant
Dim strSub As String
Dim strBody As String
Dim strArray() As String
Dim lngLoop As Long
Dim objItem As Object
Dim lngMailCounter As Long
Dim objMItem As MailItem
Dim xlApp As Excel.Application
Dim wb As Excel.Workbook
strArray = Split(EntryIDCollection, ",")
For lngMailCounter = LBound(strArray) To UBound(strArray)
Set objItem = Session.GetItemFromID(strArray(lngMailCounter))
If TypeName(objItem) = "MailItem" And InStr(1, objItem.Subject, strSubjectLineStartWith) And InStr(1, objItem.Body, "") Then
Set objMItem = objItem
Set xlApp = GetObject(, "Excel.Application")
Set wb = xlApp.Workbooks("test2.xlsx")
With wb.Sheets(1)
With .Cells(.Rows.Count, 1).End(-4162)(2).Resize(1, 7)
.Value = Array(objMItem.SenderEmailAddress, objMItem.To, objMItem.CC, objMItem.BCC, objMItem.Subject, objMItem.ReceivedTime, objMItem.Body)
End With
End With
Set objItem = Nothing
End If
Next lngMailCounter
If Not IsEmpty(strArray) Then
Erase strArray
End If

End Sub

I am not well-versed with codes. So please reply with the codes.
Thanks for your time.

 

[mrmmickle1]

Do you have MS Access? You can actually link a database to a folder in your mailbox...which would eliminate the code all together.

First Guess as to your issue: You may not be able to use the event code if it's not the primary mailbox (which a shared folder would not be)...

 

[charlests]

Do you have MS Access? You can actually link a database to a folder in your mailbox...which would eliminate the code all together.

First Guess as to your issue: You may not be able to use the event code if it's not the primary mailbox (which a shared folder would not be)...

Thanks for your response.
Yes I do have MS Access. If I link a database, will it provide the necessary info (Received time, sender address etc...) as soon as I receive a new mail in shared folder? Also if you could guide me how to link a database to a folder in mailbox, it would be great.

 

[mrmmickle1]

Go to Access:

1. Create New Database
2. Go to the External Data Tab
3. On the Import & Link section go to More
4. Select Outlook Folder
5. Select Link the data source by creating a linked table
6. Follow the prompts....

Let me know if you have issues.

Default fields are:

Excel 2010
	A
1	ID
2	Importance
3	Icon
4	Priority
5	Subject
6	From
7	Message To Me
8	Message CC to Me
9	Sender Name
10	CC
11	To
12	Received
13	Message Size
14	Contents
15	Created
16	Modified
17	Subject Prefix
18	Has Attachments
19	Normalized Subject
20	Object Type
21	Content Unread
22	submitted_date
Sheet1

 

[charlests]

I don't have mail access now. I will check tomorrow and post you back. Hope it works

 

[mrmmickle1]

Sure let me know how it goes. Here is a second method if the first one fails....

Depending on how your network is set up it could take an extended period to load the data and extract it using the connection. (i.e. If your server is a long distance away rather than being local this may not work well)


I actually use this one at work now due to the connection being to slow...You will need to add headers if you want them.

[COLOR=#0000ff]Sub [/COLOR]ExportMailByFolder()

[COLOR=#008000]    'References to the Outlook Object Library are needed (Microsoft Outlook XX.X Object Library)
    'Outlook needs to be open to run this code[/COLOR]
    
[COLOR=#008000]    'Declarations[/COLOR]
[COLOR=#0000ff]    Dim[/COLOR] ns [COLOR=#0000ff]As[/COLOR] Outlook.Namespace
   [COLOR=#0000ff] Dim [/COLOR]objFolder [COLOR=#0000ff]As [/COLOR]Outlook.MAPIFolder
[COLOR=#0000ff]    Dim[/COLOR] intCounter[COLOR=#0000ff] As Integer[/COLOR]
 [COLOR=#0000ff]   Dim[/COLOR] itmCounter[COLOR=#0000ff] As Integer[/COLOR]
[COLOR=#0000ff]    Dim[/COLOR] myTime[COLOR=#0000ff] As Double[/COLOR]
   [COLOR=#0000ff] Dim [/COLOR]recip [COLOR=#0000ff]As[/COLOR] Outlook.Recipient
    [COLOR=#0000ff]Dim [/COLOR]allRecips [COLOR=#0000ff]As String[/COLOR]
[COLOR=#0000ff]    Const[/COLOR] PR_SMTP_ADDRESS [COLOR=#0000ff]As String[/COLOR] = "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"[COLOR=#008000] 'Needed to get Email Recipient Email Addresses[/COLOR]
    
  [COLOR=#0000ff]  Set[/COLOR] ns = GetNamespace("MAPI")
 [COLOR=#0000ff]   Set[/COLOR] objFolder = ns.PickFolder [COLOR=#008000]'Pick Email Folder to Look In[/COLOR]
    
    myTime = Timer [COLOR=#008000]'Set Timer so we can see how long the process takes[/COLOR]
    
    Application.ScreenUpdating = [COLOR=#0000ff]False[/COLOR]
    
[COLOR=#0000ff]    On Error Resume Next[/COLOR]
   [COLOR=#0000ff] For[/COLOR] itmCounter = objFolder.Items.Count [COLOR=#0000ff]To [/COLOR]1 [COLOR=#0000ff]Step[/COLOR] -1
        
      [COLOR=#0000ff]  With [/COLOR]objFolder.Items(itmCounter)
    
         [COLOR=#008000]   'If this is an emai lmessage and not a task or appointment....etc then do the code below otherwise skip it[/COLOR]
          [COLOR=#0000ff]  If[/COLOR] .Class =[COLOR=#0000ff] olMail Then[/COLOR]
                
                intCounter = intCounter + 1 [COLOR=#008000]'Increment Data Input Row[/COLOR]
        
[COLOR=#008000]                'Get Email Data[/COLOR]
                Cells(intCounter, 1) = .Subject
                Cells(intCounter, 2) = .Body
                Cells(intCounter, 3) = .SenderName
                Cells(intCounter, 4) = .To
                Cells(intCounter, 4) = .Recipients [COLOR=#008000]'These are names only[/COLOR]
                Cells(intCounter, 5) = .SenderEmailAddress [COLOR=#008000]'Email UserName (Probably You....)[/COLOR]
                Cells(intCounter, 6) = .SenderEmailType
                Cells(intCounter, 7) = .CC
                Cells(intCounter, 8) = .BCC
                Cells(intCounter, 9) = .Importance
                Cells(intCounter, 10) = .Sensitivity
                Cells(intCounter, 11) = .Sender.GetExchangeUser.PrimarySmtpAddress [COLOR=#008000]'Gets Sender email address[/COLOR]
                
              [COLOR=#008000]  'To get email addresses we need to loop[/COLOR]
            [COLOR=#0000ff]    For Each[/COLOR] recip [COLOR=#0000ff]In[/COLOR] objFolder.Items(itmCounter).Recipients
              [COLOR=#0000ff]  If [/COLOR](Len(allRecips) > 0) [COLOR=#0000ff]Then[/COLOR] allRecips = allRecips & "; "
                    allRecips = allRecips & recip.PropertyAccessor.GetProperty(PR_SMTP_ADDRESS)
[COLOR=#0000ff]                Next[/COLOR]
                
                Cells(intCounter, 12) = allRecips [COLOR=#008000]'Recipient Email Addresses[/COLOR]
                Rows(intCounter).WrapText = [COLOR=#0000ff]False [/COLOR][COLOR=#008000]'Unwrap cell text[/COLOR]
                
[COLOR=#0000ff]            End If[/COLOR]

[COLOR=#0000ff]        End With[/COLOR]

[COLOR=#0000ff]    Next[/COLOR] itmCounter
[COLOR=#0000ff]    On Error GoTo 0[/COLOR]
    Application.ScreenUpdating =[COLOR=#0000ff] True[/COLOR]
    
    MsgBox "This code ran successfully in " & Round(Timer - myTime, 2) & " seconds", vbInformation[COLOR=#008000] 'MsgBox with Timer Info
    [/COLOR]
[COLOR=#008000]    'Clear Memory[/COLOR]
   [COLOR=#0000ff] Set [/COLOR]ns =[COLOR=#0000ff] Nothing[/COLOR]
 [COLOR=#0000ff]   Set [/COLOR]objFolder = [COLOR=#0000ff]Nothing[/COLOR]

[COLOR=#0000ff]End Sub[/COLOR]