XL 2019 A partir d' Excel créer lien qui ouvre directement le mail concerné d'Outlook

Public Function OpenOutlookItemFromEntryID(p_s_entryID As String) As Object
Dim l_o_olApp As Object         'Outlook.Application
Dim l_o_olNewExplorer As Object 'Outlook.Explorer
Dim l_o_olFold As Object        'Outlook.Folder
Dim l_o_olItem As Object
Dim l_b_closeOutlook As Boolean

    On Error GoTo ErrMngmt
    'main code
   
    'récupérer / créer l'application Outlook
    On Error Resume Next
     Set l_o_olApp = GetObject(, "Outlook.Application")
     l_b_closeOutlook = l_o_olApp Is Nothing
     If l_b_closeOutlook Then Set l_o_olApp = CreateObject("Outlook.Application")
    On Error GoTo ErrMngmt
    If l_o_olApp Is Nothing Then
        MsgBox "Impossible d'ouvrir l'application Outlook.", vbCritical, "Erreur"
        GoTo ErrMngmt
    End If
    If l_o_olApp.Explorers.Count = 0 Then
        l_o_olApp.Explorers.Add(l_o_olApp.Session.GetDefaultFolder(6)).Display      '6 = OlDefaultFolders.olFolderInbox
    End If
   
    On Error Resume Next
     Set l_o_olItem = l_o_olApp.Session.GetItemFromID(p_s_entryID)
     If l_o_olItem Is Nothing Then Set l_o_olFold = l_o_olApp.Session.GetFolderFromID(p_s_entryID)
    On Error GoTo ErrMngmt
   
    If Not l_o_olItem Is Nothing Then
        l_o_olItem.Display
        Set OpenOutlookItemFromEntryID = l_o_olItem
    ElseIf Not l_o_olFold Is Nothing Then
        Set l_o_olNewExplorer = l_o_olApp.Explorers.Add(l_o_olFold, 0)
        l_o_olNewExplorer.Display
        Set OpenOutlookItemFromEntryID = l_o_olFold
    Else
        MsgBox "Aucun élément n'a été trouvé dans Outlook pour l'entry ID '" & p_s_entryID & "'.", vbExclamation, "Info"
        GoTo ErrMngmt
    End If
   
QuitProc:
    On Error Resume Next
    'closure code
    Set l_o_olApp = Nothing
    Set l_o_olFold = Nothing
    Set l_o_olItem = Nothing
    Set l_o_olNewExplorer = Nothing
   
    Exit Function

ErrMngmt:
    On Error Resume Next
    If l_b_closeOutlook Then l_o_olApp.Quit
    Resume QuitProc
End Function