Accessing a shared inbox from outlook to VBA

Lehman

New Member
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:

Lehman

New Member
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:

Lehman

New Member
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

Well-known Member
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
 

Lehman

New Member
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:

Taul

Well-known Member
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")
 

Taul

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

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


 

Taul

Well-known Member
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.
 

Some videos you may like

This Week's Hot Topics

  • Importing multiple excel files into one spreadsheet
    Hi, I'm trying to import multiple excel files (with the same format into a single spreadsheet) so that each day's file is listed underneath the...
  • find many based on a certain criteria
    good evening, I hope someone can help me? I have a workbook sheet 2 contains lots of data.... I would like to be able to find anything on sheet...
  • How to copy multiple rows using If
    Hi all, I'm very new to VBA and have written this simple code to copy certain cells if a certain cell within that row contains any data. I need...
  • VBA If statement
    Dear All, I have two dates, where I'd like a message box to pop, if the dates are between this criteria. [CODE] sDate1 = #10/1/2019#...
  • Text Format
    I have a sheet for user to keyin the data. The format of the data can be 451 / 1903, 0012 / 9908 or 00287 / 0099. The number after the "/" is...
  • Syntax errors
    Good Morning, Trying to compile a workbook, I keep getting a few errors. Here are the first two: [code=rich]Syntax Error: Function...
Top