Microsoft 365 Extraire data Emails d'une boîte générique

[don_pets]

Hello la team,

je sèche un peu sur un problème con comme la lune, mais ne trouvant pas mon bonheur, et étant pris un peu par le temps, je sollicite le fofo :
Mon besoin est dans le titre, je dois extraire des infos primaires (dest, date, etc...) des emails qui sont dans une boîte générique (Outlook, serveur exchange). Les mails sont dans un sous-dossier de cette même boite générique.
Le code en dessous fonctionne très bien sur ma boite pro, mais je n'arrive pas à l'adapter pour une boîte autre que la mienne!

Anybody has a fuc**ing good idea ?

Pets

Sub TestDeMerde() 

' Variables
Dim OutlookApp  As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder      As MAPIFolder
Dim OutlookMail As Variant
Dim i           As Integer

' Déclaration
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox)
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).folders("TestExport")

' Extrac
i = 2
For Each OutlookMail In Folder.Items

   Cells(i, 1) = OutlookMail.Subject
   Cells(i, 2) = OutlookMail.ReceivedTime
   Cells(i, 3) = OutlookMail.SenderName
   Cells(i, 4) = OutlookMail.CC
   Cells(i, 5) = OutlookMail.ReceivedByName
   Cells(i, 6) = OutlookMail.Categories
i = i + 1
Next OutlookMail

' Fin instruction
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

 

[fanch55]

Bonsoir,
Ce code pourrait fonctionner :

Sub TestDeMerde()

' Variables
Dim OutlookApp          As Outlook.Application
Dim OutlookNamespace    As Namespace
Dim Folder              As MAPIFolder
Dim OutlookMail         As Variant
Dim i                   As Integer
Dim Bal                 As Outlook.Folder

' Déclaration
Set OutlookApp = New Outlook.Application
    Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
        ' Boite à lettres du mail (compte)
        Set Bal = OutlookNamespace.Folders("......@blabla.fr")
            i = 2
            Rows(i & ":" & Rows(Rows.Count).End(xlUp).Row).Clear
           ' Liste des mails du dossier Archive\Xld
            For Each OutlookMail In Bal.Folders("Archive").Folders("Xld").Items
               Cells(i, 1) = OutlookMail.Subject
               Cells(i, 2) = OutlookMail.ReceivedTime
               Cells(i, 3) = OutlookMail.SenderName
               Cells(i, 4) = OutlookMail.CC
               Cells(i, 5) = OutlookMail.ReceivedByName
               Cells(i, 6) = OutlookMail.Categories
                i = i + 1
            Next OutlookMail
            Columns.AutoFit
        Set Bal = Nothing
    Set OutlookNamespace = Nothing
Set OutlookApp = Nothing

End Sub

 

[don_pets]

Hello Fanch,

Je viens de test en adaptant à mon contexte, c'est exactement ça. Je savais bien que c'était con comme la lune.

Merci pour le coup de main