[XL-365] Excel VBA : Boite de réception Outlook - Afficher le plus récent en haut

Bonjour,

Impossible de trouver la solution

Merci pour votre aide : Comment afficher le plus récent en haut dans la vue affichée
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
 
Private Sub BT_Recherche_Outlook_Click()
Dim objNS As Object
Dim objRecip As Object
Dim objFolder As Object
Dim Messagerie As Object
Dim Compte_Utilisateur As Variant
Dim Recherche As String
Dim Extension As String
Dim Position_du_Point As Long
Application.ScreenUpdating = False
    Unload Me
    'Vérifier et ouvrir Outlook si pas ouvert
    On Error Resume Next
    Set Messagerie = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If Messagerie Is Nothing Then
        Shell "Outlook.exe" ', vbHide
    End If
    'Fin de la vérification
    Compte_Utilisateur = "p.gonin@zurbuchensa.ch"
    Extension = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Ext]").Column).Value
    If Extension = "fca01" Then
        'Recherche des renvois d'eau
        Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & "." & Extension
        Recherche = "objet:" & """" & Recherche & """"
    Else
        Position_du_Point = InStr(Extension, ".")
        If Position_du_Point = 0 Then
            If Cells(ActiveCell.Row, Range("TS_Suivi" & "[Fournisseur]").Column).Value = "Glas Trösch SA" Then
                'Recherche des cc GT
                Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & " " & Cells(ActiveCell.Row, Range("TS_Suivi" & "[Fournisseur]").Column).Value
                Recherche = "objet:" & """" & Recherche & """"
            Else
                'Recherche de la cmde sans extension
                Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value
                Recherche = "objet:" & """" & Recherche & """"
            End If
        Else
            'Recherche des avenants envoyés
            Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & "." & Right(Extension, Len(Extension) - Position_du_Point)
            Recherche = "objet:" & """" & Recherche & """"
        End If
    End If
    Set Messagerie = GetObject(, "Outlook.Application")
    Set objNS = Messagerie.GetNamespace("MAPI")
    On Error Resume Next    'permet de passer à la ligne suivante pour traiter l'erreur si le calendrier n'est pas trouvé
    Set objRecip = objNS.CreateRecipient(Compte_Utilisateur) '
    Set objFolder = objNS.GetSharedDefaultFolder(objRecip, 6)
                                                '(objRecip, 6) Mail
                                                '(objRecip, 9) Calendrier
                                                '(objRecip, 10) Contact
                                                '(objRecip, 11) Journal
                                                '(objRecip, 12) Notes
                                                '(objRecip, 13) Tâches
    objFolder.Display
    Messagerie.ActiveWindow.WindowState = olMaximized
    Messagerie.ActiveWindow.Activate
    Messagerie.ActiveExplorer.Search Recherche, 4
                                                '0 Dossier actuel
                                                '1 Toutes les boîtes aux lettres
                                                '2 Tous les éléments
                                                '3 Sous dossiers
                                                '4 Boîte aux lettres actuelle
                                                'https://learn.microsoft.com/en-us/office/vba/api/outlook.olsearchscope
    'Tri croissant = False Décroissant = True
'    Set objFolderItems = objFolder.Items
'    objFolderItems.Sort "[ReceivedTime]", True
 
    Set Messagerie = Nothing
    Set objNS = Nothing
    Set objRecip = Nothing
    Set objFolder = Nothing
Application.ScreenUpdating = True
End Sub