Option Explicit

Sub retrieve_outlook_mailes()
Dim olApp As Object, myfolder As Object
Dim oEmail As Object
Dim exists As Range, ri As Long, cnt As Long
    
    'crea un riferimento all'applicazione Outlook
    Set olApp = CreateObject("Outlook.Application")
    
    'crea un riferimento alla cartella Posta in arrivo
    'per leggere il contenuto di una sottocartella rispetto a Posta in arrivo:
    Set myfolder = olApp.GetNamespace("MAPI").GetDefaultFolder(6).Folders("Presenze - TAG")        ' 6 = olFolderInbox
    
    'contatore per accodare a dati esistenti sul foglio
    ri = [COUNTA(A:A)]
    If ri = 0 Then ri = 2 Else ri = ri + 1      'tappo di sicurezza necessario per il caso della prima esecuzione
    
    Application.ScreenUpdating = False          'non visualizza l'elaborazione in diretta, velocizza così l'esecuzione
    
    'scansione delle mail dalla cartella Outlook specirficata all'inizio
    'recupera i diversi dati e li infila cella per cella nel foglio
    'la riga 1 del foglio contiene la riga di intestazione delle colonne
    'ENTRY ID, CARTELLA, MITTENTE, DATA, OGGETTO, CORPO, ALLEGATI

    For Each oEmail In myfolder.items
        With oEmail
            Set exists = Range("A:A").Find(.EntryID)    'cerca l'ID univoco della mail (generato da Outlook) per evitare di ricopiare doppioni
            If exists Is Nothing Then
                Cells(ri, "A") = .EntryID         'entryID
                Cells(ri, "B") = .Parent          'cartella outlook
                Cells(ri, "C") = .SenderName      'mittente
                Cells(ri, "D") = .ReceivedTime    'data dell'email
                Cells(ri, "E") = .Subject         'oggetto
                Cells(ri, "F") = .Body            'corpo del messaggio
                Cells(ri, "G") = .Attachments.Count        'numero di allegati
                Rows(ri).WrapText = False
                ri = ri + 1
                cnt = cnt + 1
            End If
        End With
    Next
    
    Set myfolder = Nothing
    Set olApp = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "Finito. Ho importato " & cnt & " elementi."
End Sub

Public Sub ListOutlookFolders()
     
    Dim olApp As Outlook.Application
    Dim olNamespace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim rngOutput As Range
    Dim lngCol As Long
    Dim olItem As Outlook.MailItem
     
    Set rngOutput = ActiveSheet.Range("A1")
     
    Set olApp = New Outlook.Application
    Set olNamespace = olApp.GetNamespace("MAPI")
     
    For Each olFolder In olNamespace.Folders
        rngOutput = olFolder.Name
        rngOutput.Offset(0, 1) = olFolder.Description
        Set rngOutput = rngOutput.Offset(1)
        For Each olItem In olFolder.Items
            Set rngOutput = rngOutput.Offset(1)
            With rngOutput
                .Offset(0, 1) = olItem.SenderName ' Sender
                .Offset(0, 2) = olItem.Subject ' Subject
                .Offset(0, 3) = olItem.ReceivedTime ' Received
                .Offset(0, 4) = olItem.ReceivedByName ' Recepient
                .Offset(0, 5) = olItem.UnRead ' Unread?
                .Offset(0, 6) = olItem.ReplyRecipientNames '
                .Offset(0, 7) = olItem.SentOn
            End With
        Next
         
        Set rngOutput = ListFolders(olFolder, 1, rngOutput)
    Next
     
    Set olFolder = Nothing
    Set olNamespace = Nothing
    Set olApp = Nothing
     
End Sub
Function ListFolders(MyFolder As Outlook.MAPIFolder, Level As Integer, Output As Range) As Range
     '
     '
     '
    Dim olFolder As Outlook.MAPIFolder
    Dim olItem As Outlook.MailItem
    Dim lngCol As Long
     
    For Each olFolder In MyFolder.Folders
        lngCol = ((Level - 1) * 8) + 1
        Output.Offset(0, lngCol) = olFolder.Name
        Set Output = Output.Offset(1)
        If olFolder.DefaultItemType = olMailItem Then
            For Each olItem In olFolder.Items
                With Output
                    .Offset(0, lngCol + 1) = olItem.SenderName ' Sender
                    .Offset(0, lngCol + 2) = olItem.Subject ' Subject
                    .Offset(0, lngCol + 3) = olItem.ReceivedTime ' Received
                    .Offset(0, lngCol + 4) = olItem.ReceivedByName ' Recepient
                    .Offset(0, lngCol + 5) = olItem.UnRead ' Unread?
                    .Offset(0, lngCol + 6) = olItem.ReplyRecipientNames '
                    .Offset(0, lngCol + 7) = olItem.SentOn
                     
                End With
                Set Output = Output.Offset(1)
            Next
        End If
        If olFolder.Folders.Count > 0 Then
            Set Output = ListFolders(olFolder, Level + 1, Output)
        End If
    Next
    Set ListFolders = Output.Offset(1)
     
End Function