Outlook Récupérer EntryId d'un mail après déplacement

[Polobe36]

Bonjour à tous, le Forum,

J'aurai à nouveau besoin de votre aide. J'ai fouillé sur les différents forums et sur le MSDN.microsoft, mais malheureusement mes compétences sont plus que limitées dans le domaine..

Depuis Excel, je fais l'extraction des mails de dossiers de mon arborescence Outlook dans un onglet de mon classeur. Dans les champs exportés se trouve notamment le champ EntryId, qui me permet d'obtenir un identifiant unique par mail.

Mon problème est que lorsque je déplace un mail vers un autre dossier, le champ EntryId change (normal si j'en crois MSDN.microsoft), sauf que je ne sais pas comment récupérer cet EntryId pour écraser la valeur correspondante dans mon onglet Excel, et ainsi pouvoir le traiter à nouveau depuis ma procédure sous Excel.

Je précise que le code ci-après est la procédure qui me permet depuis Excel de traiter un mail (création dossier Outlook si inexistant, modification du mail, déplacement du mail, extraction pièces jointes, ...)

J'espère être suffisamment explicite, je vous remercie par avance de votre aide.
Bien cordialement.

Sub GestionMail()

Dim olApp As Object, NS As Object, Dossier As Object, DestDossier As Object
Dim OlExp As Object
Dim i As Object
Dim MailATraiter As String, CodeDossier As String
Dim DossierSujet As Outlook.Folder
Dim j As Integer
Dim PieceJointe As Object
          

'Définition de la cellule active
    MailATraiter = Sheets("Feuil1").Cells(ActiveCell.Row, ActiveCell.Column).Address
'Recherche du CodeSujet
    CodeSujet = Sheets("Feuil1").Cells(ActiveCell.Row, 3).Value
    If CodeSujet = "" Then
        MsgBox ("Pas de CodeSujet affecté. Fin")
        Exit Sub
    End If

If MsgBox("Traiter le mail: " & Sheets("Feuil1").Cells(ActiveCell.Row, 6) & " du " & Sheets("Feuil1").Cells(ActiveCell.Row, 8) & " de " & Sheets("Feuil1").Cells(ActiveCell.Row, 7), vbYesNo, "Confirmation requise") = vbYes Then
'Recherche/Création du dossier d'archivage Outlook
    Set olApp = CreateObject("Outlook.Application")
    Set OlExp = olApp.ActiveExplorer
    Set NS = olApp.GetNamespace("MAPI")
    Set Dossier = NS.Folders("moi").Folders("Boîte de réception").Folders("Sujet")
    CodeDossier = CodeSujet
    For Each DossierSujet In Dossier.Folders
        If DossierSujet.Name = CodeDossier Then
            Set Dossier = Dossier.Folders(CodeDossier)
            Exit For
        End If
    Next
    If DossierSujet Is Nothing Then
        Set DossierSujet = Dossier.Folders.Add(CodeDossier)
    End If
'Traitement du mail
    Set DossierATraiter = NS.Folders("moi").Folders("Boîte de réception").Folders("A_Traiter")
    For Each i In DossierATraiter.Items
           If i.EntryID = Sheets("Feuil1").Cells(ActiveCell.Row, 5).Value Then 'Subject = Sheets("Feuil1").Cells(ActiveCell.Row, 6).Value Then
            'i.Categories = Sheets("Feuil1").Cells(ActiveCell.Row, 13)
            i.Importance = Sheets("Feuil1").Cells(ActiveCell.Row, 4).Value
            i.ClearTaskFlag 'efface l'indicateur tâche
            'i.FlagRequest = "Assurer un suivi" 'type de suivi
            'i.ReminderTime = "10/01/2017 12:00 PM" 'date de rappel
            'i.ReminderOverrideDefault = True
            'i.ReminderSet = True
            'i.TaskStartDate = "08/01/2017" 'date début échéance
            'i.TaskDueDate = "09/01/2017" 'date fin échéance
            'i.TaskCompletedDate = "07/01/2017" 'date fin de tâche
          
        'Sauvegarde des pièces jointes
            'Set PieceJointe = i.Attachments
            'If PieceJointe.Count > 0 Then
            '    For j = 1 To PieceJointe.Count
            '        CreationRepertoire "C:\", CodeDossier
            '        CheminDossier = "C:\" & CodeDossier & "\"
            '        PieceJointe(j).SaveAsFile CheminDossier & PieceJointe(j).DisplayName
            '    Next
            'End If
        'Suppression image signature
            'ChDrive "C"
            'ChDir "C:\" & CodeDossier
            'On Error Resume Next
            'Kill "image001.jpg"
        'Archivage
            'i.Save 'Sauvegarde
            i.Move DossierSujet
            nouveauId =??? '<========= c'est là où je ne sais pas comment récupérer le nouvel EntryId
            Sheets("Feuil1").Cells(ActiveCell.Row, 5).Value = nouveauId
        End If
    Next i
End If

MsgBox ("Mail " & Sheets("Feuil1").Cells(ActiveCell.Row, 6) & " du " & Sheets("Feuil1").Cells(ActiveCell.Row, 8) & " de " & Sheets("Feuil1").Cells(ActiveCell.Row, 7) & "traité")

    Set olApp = Nothing
    Set OlExp = Nothing
    Set NS = Nothing
    Set Dossier = Nothing
    Set DossierATraiter = Nothing
    Set PieceJointe = Nothing
 
End Sub

 

[Polobe36]

Re,

Je me permet d'ouvrir la discussion, peut-être existe t'il un champ disponible en écriture dans lequel l'on puisse mettre une valeur. Ce qui me permettrait du coup d'avoir un ID unique "généré" depuis Excel.
J'ai recherché du côté de MailItem.UserProperties, mais j'ai du mal à mettre en application.

Merci d'avance de votre aide