Extracting SubFolders from Outlook using Excel VBA

[imlearningexcelvba]

I would like to extract out subject from shared outlook email. I manage to extract out inbox but subfolder are not extracted out. Anything wrong with my code below?
Shared email > Inbox > subfolder1 (under subfolder 1 has few folders)

Public xlSht As Excel.Worksheet


Sub DocumentFolders(objParent As Folder, lRow As Long)
Dim objItm As Object
Dim objFolder As Folder



Dim strMailboxName As String

  Dim Ns As Outlook.Namespace
  Dim olShareName As Outlook.Recipient
  
  Dim subFolder As Object

  Set OutlookApp = New Outlook.Application
  Set Ns = OutlookApp.GetNamespace("MAPI")
  
  Set olShareName = Ns.CreateRecipient("xxx@xxx.COM") '// Owner's email address
  Set objParent = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox) '// Inbox


    On Error Resume Next
    With xlSht
        For Each objItm In objParent.Items
            .Cells(lRow, 1) = objParent
            .Cells(lRow, 2) = objItm.ReceivedTime
            .Cells(lRow, 3) = objItm.Subject
            lRow = lRow + 1
        Next
    End With
    On Error GoTo 0
    
    If objParent.Folders.Count > 0 Then
        For Each objFolder In objParent.Folders
            Call DocumentFolders(objFolder, lRow)
        Next
    End If





End Sub




Sub ExportInformation()
Dim xlApp As Excel.Application
Dim xlWb As Excel.Workbook



    Set xlApp = New Excel.Application
    Set xlWb = xlApp.Workbooks.Add
    Set xlSht = xlWb.Sheets(1)
    
    
    With xlSht
        .Cells(1, 1) = "Folder"
        .Cells(1, 2) = "Received Time"
        .Cells(1, 3) = "Subject"
    End With
    
    
    Call DocumentFolders(Session.GetDefaultFolder(olFolderInbox), 2)
    
    xlApp.Visible = True



Set xlSht = Nothing
Set xlWb = Nothing
Set xlApp = Nothing




End Sub

 

[imlearningexcelvba]

any help here? im still stuck not able to extract out the subfolders.

 

[DanteAmor]

deleted

 

[imlearningexcelvba]

deleted

deleted?

 

[DanteAmor]

Sorry I deleted my answer because I read that you want it for all subfolders, this was my answer. Maybe it will help you something.

Sub GetEmail_2()
'Fuente: http://stackoverflow.com/questions/8322432/using-visual-basic-to-access-subfolder-in-inbox
'fuente: http://www.snb-vba.eu/VBA_Outlook_external_en.html
'fuente: https://support.microsoft.com/en-us/kb/208520
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim subfolder As Object
    Dim MyItems As Variant
    Dim msg As Outlook.MailItem
    Dim f As Long, n As Long, NumItems As Long
    '
    Application.ScreenUpdating = False
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    '
    Set olFolder = objNS.Folders("Respaldo 2018 1 semestre")
    Set subfolder = olFolder.Folders("Entradas")
    Set MyItems = subfolder.Items
    Columns("A:C").Clear
    NumItems = subfolder.Items.Count
    f = 1
    On Error Resume Next
    For n = 1 To NumItems
        Cells(f, "A") = MyItems(n).SenderName
        Cells(f, "B") = MyItems(n).Subject
        Cells(f, "C") = MyItems(n).body
        f = f + 1
    Next
    Columns("B:C").WrapText = False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

 

[imlearningexcelvba]

Sorry I deleted my answer because I read that you want it for all subfolders, this was my answer. Maybe it will help you something.

Sub GetEmail_2()
'Fuente: http://stackoverflow.com/questions/8322432/using-visual-basic-to-access-subfolder-in-inbox
'fuente: http://www.snb-vba.eu/VBA_Outlook_external_en.html
'fuente: https://support.microsoft.com/en-us/kb/208520
    Dim olApp As Outlook.Application
    Dim objNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim subfolder As Object
    Dim MyItems As Variant
    Dim msg As Outlook.MailItem
    Dim f As Long, n As Long, NumItems As Long
    '
    Application.ScreenUpdating = False
    Set olApp = Outlook.Application
    Set objNS = olApp.GetNamespace("MAPI")
    '
    Set olFolder = objNS.Folders("Respaldo 2018 1 semestre")
    Set subfolder = olFolder.Folders("Entradas")
    Set MyItems = subfolder.Items
    Columns("A:C").Clear
    NumItems = subfolder.Items.Count
    f = 1
    On Error Resume Next
    For n = 1 To NumItems
        Cells(f, "A") = MyItems(n).SenderName
        Cells(f, "B") = MyItems(n).Subject
        Cells(f, "C") = MyItems(n).body
        f = f + 1
    Next
    Columns("B:C").WrapText = False
    Application.ScreenUpdating = True
    MsgBox "End"
End Sub

How can I extract out from shared email. As my outlook has few shared email. Is this right?

 Set olShareName = Ns.CreateRecipient("xxx@xxx.COM") '// Owner's email address
  Set objParent = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox) '// Inbox

 

[imlearningexcelvba]

How can I extract out from shared email. As my outlook has few shared email. Is this right?

 Set olShareName = Ns.CreateRecipient("xxx@xxx.COM") '// Owner's email address
  Set objParent = Ns.GetSharedDefaultFolder(olShareName, olFolderInbox) '// Inbox

Anyone able to solve this?