Accessing a shared inbox from outlook to VBA

Lehman

New Member
Joined
Oct 5, 2019
Messages
13
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.

Code:
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!
 
Last edited by a moderator:

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
So these are the shared inboxes:
Code:
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.
 
Last edited by a moderator:
Upvote 0
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!
 
Upvote 0
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.



Code:
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
 
Upvote 0
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
Code:
Set Folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)
To Subfolder in inbox "Values" and then subfolder called "2019"?
 
Last edited:
Upvote 0
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:-
Code:
Set Folder = OutlookNamespace.GetSharedDefaultFolder(objOwner, olFolderInbox)

to this:-
Code:
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Values").Folders("2019")
 
Upvote 0
Opps!, I forgot to include the shared bit,
change it to:-

Rich (BB code):
Set Folder = OutlookNamespace.GetSharedDefaultFolder(olFolderInbox).Folders("Values").Folders("2019")


 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,527
Messages
6,114,150
Members
448,552
Latest member
WORKINGWITHNOLEADER

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top