Accessing a shared inbox from outlook to VBA

[Lehman]

Hello,

I have written some code that retrieves the number of mails from two inboxes. I've tested it locally however when I am trying to connect to a Shared Inbox, it returns a 0. I am very confused and I am wondering if someone can help me.
The names of the two shared inboxes are 1) FolderA and 2) FolderB. Both have some folders and subfolders in the following combination:
Shared inbox Folder Subfolder
[FolderA, Values]
[FolderA, Margins, PastMargins]
[FolderA, Lesbeque, Research]
[FolderB, Internal Commitments, Attached]
[FolderB, Extern Commitments, New]
Those routes leads to the desired mailbox where I try to extract the count.

Sub GetFromOutlook()
    Dim folderlist1, folderlist2 As Variant
    Dim num_of_folders As Variant
    Dim accounts As Variant
    Dim accname As String
    Dim count As Integer
    Dim sheetName As String
    
    sheetName = "Import"
    accounts = Array("FolderA", "FolderB") ' account name should be here
    num_of_folders = Array(3, 2)
    folderlist1 = Array("Values", "Margins", "Lesbeque", "Intern", "Extern") ' folders list
    folderlist2 = Array("NULL", "PastMargins", "Research", "Attached", "New") ' sub folders like test02 in WS1, if there is no sub folder write NULL
    lastRow = Worksheets(sheetName).Cells(Rows.count, 1).End(xlUp).Row
    colIndex = 1
    folder_index = LBound(folderlist1)
    
    For kk = LBound(accounts) To UBound(accounts)
        accname = accounts(kk)
        For ii = folder_index To (folder_index + num_of_folders(kk) - 1)
            If folderlist2(ii) = "NULL" Then
                count = GetFolderCount(accname, folderlist1(ii))
            Else
                count = GetSubFolderCount(accname, folderlist1(ii), folderlist2(ii))
            End If
            Worksheets(sheetName).Cells(lastRow + 1, colIndex).Value = count
            colIndex = colIndex + 1
        Next ii
        folder_index = folder_index + num_of_folders(kk)
    Next kk
End Sub


Function GetFolderCount(ByVal accname As String, ByVal folder1 As String)
    Dim OutlookApp As Outlook.Application
    Dim oaccount As Outlook.Account
    Dim ostore As Outlook.store
    Dim OutlookNamespace As Namespace
    Dim Folder As MAPIFolder
    Dim OutlookMail As Variant
    Dim i As Integer
    Dim myNameSpace As Outlook.Namespace
    Dim sheetName As String
    
    sheetName = "Import"
    Set OutlookApp = New Outlook.Application
    
    For Each oaccount In OutlookApp.Session.accounts
        If oaccount = accname Then
            Set ostore = oaccount.DeliveryStore
            Set Folder = ostore.GetDefaultFolder(olFolderInbox).folders(folder1)
            i = 0 'Folder.ShowItemCount
            For Each OutlookMail In Folder.Items
                If TypeOf OutlookMail Is MailItem Then
                        i = i + 1
                End If
            Next OutlookMail
            
            Set Folder = Nothing
            Set OutlookNamespace = Nothing
            Set OutlookApp = Nothing
        End If


    Next oaccount
    
    GetFolderCount = i


End Function


Function GetSubFolderCount(ByVal accname As String, ByVal folder1 As String, ByVal folder2 As String)
    Dim OutlookApp As Outlook.Application
    Dim oaccount As Outlook.Account
    Dim ostore As Outlook.store
    Dim OutlookNamespace As Namespace
    Dim Folder As MAPIFolder
    Dim OutlookMail As Variant
    Dim i As Integer
    Dim myNameSpace As Outlook.Namespace
    Dim sheetName As String
    
    sheetName = "Import"
    Set OutlookApp = New Outlook.Application
    
    For Each oaccount In OutlookApp.Session.accounts
        If oaccount = accname Then
            Set ostore = oaccount.DeliveryStore
            Set Folder = ostore.GetDefaultFolder(olFolderInbox).folders(folder1).folders(folder2)
            i = 0 'Folder.ShowItemCount
            For Each OutlookMail In Folder.Items
                If TypeOf OutlookMail Is MailItem Then
                        i = i + 1
                End If
            Next OutlookMail
            
            Set Folder = Nothing
            Set OutlookNamespace = Nothing
            Set OutlookApp = Nothing
        End If
        'ostore = Nothing
    Next oaccount
    
    GetSubFolderCount = i

End Function

I am very much wondering is someone can help me!

 

[Lehman]

So these are the shared inboxes:

accounts = Array("FolderA","FolderB")

The code above only works when you put @outlook.com or something else behind it.. However the shared inboxes have none like that.

 

[Lehman]

So with some searching on the internet; they use the GetSharedDefaultFolder function. However they use it to return an calendar and not a inbox or multiple inboxes. Please help!

 

[Taul]

Hi,
I'm not sure if this will help but below is a code I use to pull emails from a shared account. You may be able to adapt it to suit your needs.
there are bits of code in it that you may be looking for.
cheers
Paul.

Sub GetFromOutlook()


Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer
Dim olNS As Outlook.Namespace


Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")


'**** this bit is added to get a shared email ******
    Set objOwner = OutlookNamespace.CreateRecipient("training@company.com")
    objOwner.Resolve


    If objOwner.Resolved Then
        Set Folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox) 'can use olFolderInbox or olFolderSentMail
    End If
'*****************************************************
'or use this approach
'Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Net Sales Report").Folders("Sales")
        'Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox)' use Inbox or SentMail, not both
        'Set Folder = OutlookNamespace.GetDefaultFolder(olFolderSentMail)


'        'Get the appointments from Outlook
'        Set olkLst = olkFld.Items
'        olkLst.Sort "[Start]"
'        olkLst.IncludeRecurrences = True ' this is for calendar items
'        Set olkRes = olkLst.Restrict("[Start] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Start] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
'        'Write appointments to spreadsheet
'        For Each olkApt In olkRes
'Set olkRes = olkLst.Restrict("[Start] >= '" & Format(datBeg, "ddddd h:nn AMPM") & "' AND [Start] <= '" & Format(datEnd, "ddddd h:nn AMPM") & "'")
'******************************************************


'Write mail to spreadsheet - create named range, from and to dates on the spreadsheet
i = 1
For Each OutlookMail In Folder.Items
    'If OutlookMail.ReceivedTime >= Range("From_date").Value Then
    If OutlookMail.ReceivedTime >= Range("From_date").Value And OutlookMail.ReceivedTime <= Range("To_date").Value Then
        Range("eMail_date").Offset(i, 0).Value = OutlookMail.ReceivedTime
        Range("eMail_sender").Offset(i, 0).Value = OutlookMail.SenderName
        Range("eMail_recipient").Offset(i, 0).Value = OutlookMail.To
        Range("eMail_subject").Offset(i, 0).Value = OutlookMail.Subject
        Range("eMail_text").Offset(i, 0).Value = OutlookMail.Body
        Range("eMail_cc").Offset(i, 0).Value = (OutlookMail.CC)
        Range("eMail_bcc").Offset(i, 0).Value = (OutlookMail.BCC)
        i = i + 1
    End If
Next OutlookMail


Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing


End Sub

 

[Taul]

Hi,
This may also help

https://www.mrexcel.com/forum/excel-questions/870371-vba-copy-mail-shared-outlook-mailbox-excel.html

 

[Lehman]

Hey Taul, thank you very much. I have a folder in the inbox, it's called Values and there in a subfolder called 2019. I have managed to get the whole inbox in it but not able to get the subfolders.

How can I extend the line

Set Folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)

To Subfolder in inbox "Values" and then subfolder called "2019"?

 

[Taul]

Hi,
Quote:- "I have a folder in the inbox, it's called Values and there in a subfolder called 2019"

I cant test this but try

Change this:-

Set Folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)

to this:-

Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Values").Folders("2019")

 

[Taul]

Opps!, I forgot to include the shared bit,
change it to:-

Set Folder = OutlookNamespace.GetSharedDefaultFolder(olFolderInbox).Folders("Values").Folders("2019")

 

[Lehman]

Hey Taul, yes your solutions are working! However now I have another problem; wondering if you can help me with that.
When I use two different shared mailboxes, I get an registry error. I have asked the question here: https://www.mrexcel.com/forum/excel...ing-2-shared-outlook-mailboxes-same-time.html

Can you perhaps help me with that? Ill be you forever grateful!

 

[Taul]

Hi Lehman,
Good to hear the code is working.
I’ve never tried to pull from two or more different email accounts at the same time, so I’m not sure how to do that.
I’m guessing you may need to make two separate connections to Outlook, so as one code (your working code) finishes, you repeat the action for the next email account.
There is probably a smarter way to achieve this by cresting a loop but you will have to either experiment with it or wait for someone else to reply.