VBA code to import emails into excel from shared mailbox

[STEVENS3010]

Hi all,

Is anybody able to help with the below code? I'm trying to import emails into an excel sheet from a shared mailbox but there seems to be a problem. I've tried the code from my own personal mailbox and it works so not sure what the issue is. The debug error message seems to point to the inbox name. I've used a dummy name in the code below. Can anybody point me in the right direction?

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
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.Folders("dummyinobxname@workemail.co.uk")
    Set olFldr = olFldr.Folders("Inbox")
    
    ws.Cells.Clear
    iRow = 2
    
    Application.ScreenUpdating = False
    For Each olItem In olFldr.Items
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            With olMailItem
                ws.Cells(iRow, "A") = .Subject
                ws.Cells(iRow, "B") = .ReceivedTime
                ws.Cells(iRow, "C") = .Categories
                iRow = iRow + 1
            End With
        End If
    Next olItem

    With ws
        hdr = Array("Subject", "ReceicedTime", "Categories")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = False
End Sub

 

[STEVENS3010]

Hi all, I've managed to sort this problem. It appears I didn't need to use the full mail box name and only the folder name to sort the issue. Now I have the code working as I need it to, is anybody able to help with another issue I now have.

The code above is pulling emails from one folder but I need the code to pick up emails from three different folders and to paste the contents onto three different sheets (Sheet 1, Sheet 2 and Sheet 3). At the minute I have 3 seperate codes to achieve this but is it possible to combine the three different codes so all this is done in one instead? The three separate codes I am using at the moment are below. Any help would be really appreciated as I have very limited VBA coding knowledge, everything I have so far if some other posts on the forum....

Code 1

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
    
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.Folders("Dummy Folder")
    Set olFldr = olFldr.Folders("Inbox")
    Set olFldr = olFldr.Folders("Dummy Sub Folder")
    Set olFldr = olFldr.Folders("Work 1 Folder")
    
    ws.Cells.Clear
    iRow = 2
    
    Application.ScreenUpdating = False
    For Each olItem In olFldr.Items
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            With olMailItem
                ws.Cells(iRow, "A") = .Subject
                ws.Cells(iRow, "B") = .ReceivedTime
                ws.Cells(iRow, "C") = .Categories
                iRow = iRow + 1
            End With
        End If
    Next olItem

    With ws
        hdr = Array("Subject", "ReceicedTime", "Categories")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = False
End Sub

Code 2

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
    
    Set ws = ThisWorkbook.Worksheets("Sheet2")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.Folders("Dummy Folder")
    Set olFldr = olFldr.Folders("Inbox")
    Set olFldr = olFldr.Folders(" Dummy Sub Folder")
    Set olFldr = olFldr.Folders("Work 2 Folder")
    
    ws.Cells.Clear
    iRow = 2
    
    Application.ScreenUpdating = False
    For Each olItem In olFldr.Items
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            With olMailItem
                ws.Cells(iRow, "A") = .Subject
                ws.Cells(iRow, "B") = .ReceivedTime
                ws.Cells(iRow, "C") = .Categories
                iRow = iRow + 1
            End With
        End If
    Next olItem

    With ws
        hdr = Array("Subject", "ReceicedTime", "Categories")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = False
End Sub

Code 3

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
    
    Set ws = ThisWorkbook.Worksheets("Sheet3")
    
    Set olApp = New Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    
    Set olFldr = olNS.Folders("Dummy Folder")
    Set olFldr = olFldr.Folders("Inbox")
    Set olFldr = olFldr.Folders("Dummy Sub Folder")
    Set olFldr = olFldr.Folders("Work 3 Folder")
    
    ws.Cells.Clear
    iRow = 2
    
    Application.ScreenUpdating = False
    For Each olItem In olFldr.Items
        If olItem.Class = olMail Then
            Set olMailItem = olItem
            With olMailItem
                ws.Cells(iRow, "A") = .Subject
                ws.Cells(iRow, "B") = .ReceivedTime
                ws.Cells(iRow, "C") = .Categories
                iRow = iRow + 1
            End With
        End If
    Next olItem

    With ws
        hdr = Array("Subject", "ReceicedTime", "Categories")
        .Range("A1").Resize(, UBound(hdr)) = hdr
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = False
End Sub

 

[STEVENS3010]

Does anybody know of this is possible?