VBA: Copy mail from shared outlook mailbox to excel

[Kruijf]

Hi all,

I have question, im looking for a macro that copies mail from a shared mailbox to excel. I do understand a little bit of VBA but im not good with writing my own macro's (yet). On the internet i found a macro that copies mail from specific folder in my default mail account, but that one does not work with shared mailboxes.

We need mails from specific folders in outlook in Excel so we can use the data for some reports that we make daily. Because it takes a while to copy those mails we would like to automate this with a macro. I did search on the internet but on a few occasions i found that people noted that it was not possible. We're using Office 2013.

So my questions are.
- Is it possible to do this with VBA?
- If so, does anybody have a macro that i can use for my situation?


I hope it's clear what we need, hopefully it's possible and somebody can send me in the right direction.
Thanks in advance.

Kind regards,
Tom

 

[RickXL]

Hi,

If the folder list was fixed then this would work.

' Requires Tools-->References-->Microsoft Outlook 15.0 Object Library
Sub getEmails()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFldr As Outlook.MAPIFolder
    Dim olItem As Object
    Dim olMailItem As Outlook.MailItem
    Dim ws As Worksheet
    Dim iRow As Long
    Dim hdr As Variant
    Dim iFldr As Long
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
     
    With ws
        iRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    Application.ScreenUpdating = False
    
    For iFldr = 1 To 2
        Select Case iFldr
            Case 1
                Set olFldr = olNS.Folders(1)
                Set olFldr = olFldr.Folders("Inbox")
                Set olFldr = olFldr.Folders("MrExcel")
                Set olFldr = olFldr.Folders("Keep")
            Case 2
                Set olFldr = olNS.Folders(1)
                Set olFldr = olFldr.Folders("Inbox")
                Set olFldr = olFldr.Folders("Z Test")
            Case Else
        End Select

        For Each olItem In olFldr.Items
            If olItem.Class = olMail Then
                Set olMailItem = olItem
                With olMailItem
                    iRow = iRow + 1
                    If Not .Sender Is Nothing Then ws.Cells(iRow, "A") = .Sender
                    ws.Cells(iRow, "B") = .SenderEmailAddress
                    ws.Cells(iRow, "C") = .SenderName
                    ws.Cells(iRow, "D") = .Subject
                    ws.Cells(iRow, "E") = .ReceivedTime
                    ws.Cells(iRow, "F") = .Categories
                    ws.Cells(iRow, "G") = .TaskCompletedDate
                    ws.Cells(iRow, "H") = olFldr.Name
                End With
            End If
        Next olItem
    Next iFldr

    With ws
        hdr = Array("Sender", "SenderEmailAddress", "SenderName", "Subject", "ReceivedTime", "Categories", "TaskCompletedDate", "Folder")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    
    Application.ScreenUpdating = False
    
End Sub

Note: I have modified the line that outputs the Sender. In my Z Test folder there were some Undelivered Mail entries and they have the Sender set to Nothing - not just blank.

Just keep adding new Cases in the Select Case structure for new folder hierarchies.

I started using Folders(1) because my first folder has the same name as my email address. When I paste things into here I sometimes forget to remove that kind of detail. However, Folders(1) works and gets round that problem. You should probably stick to using a name though. Numbers can change when folders are reorganised.

If every folder will be in the Inbox then the

                Set olFldr = olNS.Folders(1)
                Set olFldr = olFldr.Folders("Inbox")

lines could be moved outside the Select Case block so that it appears only once. If you want every folder in a hierarchy then we may have to devise a recursive folder search instead.

 

[Kruijf]

Hi RickXL,

Thanks again, i will test the codes today to see how it works.

The folder structuur that we have for some customers is that we need to go for 2 or 3 folders down and under that folder we have the name of our customers with 3 to 6 folders where all the mail is in. We need all the mail from all folders, there are no exeptions. The folder names under the folder for the customers are mostly the same.

Above the cases you have the line: For iFldr = 1 To 2, those the 2 need to be change to the count of how many cases you have?

 

[Kruijf]

Just tested the code and it works awesome

And i also answered my own question, i need to change the number to the count of how many cases i have.

Will do some further testing.
Thanks again for your help.

A question little bit of topic: How did you learn all this? Are there some good ebooks on how to make macro's for office applications?

 

[RickXL]

A question little bit of topic: How did you learn all this? Are there some good ebooks on how to make macro's for office applications?

I have used Office for many years but have not ventured into any serious VBA until quite recently. It always seemed to be too difficult to make it work to be useful! Eventually I was able to get it to do what I wanted. I was not used to object oriented programming and you do need to have an understanding of each application's object model before you can make much progress.

However, I have been using other languages for ages and a couple of years ago I decided to try and answer some questions on the web to try and educate myself about Excel VBA. I ended up here and have improved a lot in the last 12 months. Writing programs is quite easy these days. You just use Google until you find someone else who has done it! Before the internet, and working by yourself, things were much harder.

If you search the internet for solutions you quickly spot that the same sites keep popping up so you can bookmark them. I found this the other day. It looks quite interesting: http://bprd.nic.in/writereaddata/li...007 VBA Programmers Reference - Wrox 2007.pdf

 

[Kruijf]

Hi Rick,

Thanks for the macro, we love it! Takes a lot of work from our hands.

The pdf file is definitely cool, i have seen a lot of interesting stuff in it. Thank you for that!

Thanks for all your help and maybe we will see each other on the forum.

Greetings Tom

 

[RickXL]

Hi,

No problem. I am glad you found it useful and thanks for the feedback.

Who knows when our paths will cross again?

Regards,

 

[chinchi81]

Hi,

Great thread and macro, I've been able to adapt it for my requirement... except for 1 area... Is it possible to add lines to this to include attachments, i.e. in column I I am looking to have the name of any attachments added into that column.

Thanks
Philip

 

[RickXL]

Hi,

It is usually preferable to start a new thread when asking a new question - particularly after a time lag. This is partly because I might no longer be here and it would reduce the chances of someone else noticing it.

However, this seems to work:

' Requires Tools-->References-->Microsoft Outlook 15.0 Object Library
Sub getEmails()

    Dim olApp       As Outlook.Application
    Dim olNS        As Outlook.Namespace
    Dim olFldr      As Outlook.MAPIFolder
    Dim olItem      As Object
    Dim olMailItem  As Outlook.MailItem
    Dim ws          As Worksheet
    Dim iRow        As Long
    Dim hdr         As Variant
    Dim iFldr       As Long
    Dim lstAtt      As String
    Dim olAtt       As Outlook.Attachment
    Dim dlm         As String
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
     
    With ws
        iRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    Application.ScreenUpdating = False

    For iFldr = 1 To 1
        Select Case iFldr
            Case 1
                Set olFldr = olNS.Folders(2)
                Set olFldr = olFldr.Folders("Inbox")
                Set olFldr = olFldr.Folders("MrExcel")
                Set olFldr = olFldr.Folders("Keep")
            Case 2
                Set olFldr = olNS.Folders(2)
                Set olFldr = olFldr.Folders("Inbox")
                Set olFldr = olFldr.Folders("Z Test")
            Case Else
        End Select

        For Each olItem In olFldr.Items
            If olItem.Class = olMail Then
                Set olMailItem = olItem
                With olMailItem
                    iRow = iRow + 1
                    If Not .Sender Is Nothing Then ws.Cells(iRow, "A") = .Sender
                    ws.Cells(iRow, "B") = .SenderEmailAddress
                    ws.Cells(iRow, "C") = .SenderName
                    ws.Cells(iRow, "D") = .Subject
                    ws.Cells(iRow, "E") = .ReceivedTime
                    ws.Cells(iRow, "F") = .Categories
                    ws.Cells(iRow, "G") = .TaskCompletedDate
                    ws.Cells(iRow, "H") = olFldr.Name
                    lstAtt = ""
                    dlm = ""
                    For Each olAtt In .attachments
                        lstAtt = lstAtt & dlm & olAtt.DisplayName
                        dlm = Chr(10)
                    Next
                    ws.Cells(iRow, "I") = lstAtt
                End With
            End If
        Next olItem
    Next iFldr

    With ws
        hdr = Array("Sender", "SenderEmailAddress", "SenderName", "Subject", "ReceivedTime", "Categories", "TaskCompletedDate", "Folder", "Attachments")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    
    Application.ScreenUpdating = False
    
End Sub

It loops round the attachments and adds the display name to a list of attachments. This is a string and the individual names are delimited by a Chr(10) character. This will cause a line break when copied to a worksheet cell.

Note: I have reorganised my folders and my start folder is now number 2. (Set olFldr = olNS.Folders(2)) Yours should be unchanged, however.

Regards,

 

[chinchi81]

Hi Rick,

Thanks for that, it works perfectly. I'm glad the risk I took replying to the thread paid off

Thanks
Philip

 

[RickXL]

No problem. Thanks for letting me know.

Yes, sometimes you get lucky.


Regards,