Excel VBA : Lancer une recherche dans la boite mail Outlook

Version imprimable

2 pièce(s) jointe(s)

Bonjour,

J'ai trouvé ce code sur internet, mais il ne fonctionne pas avec XL-365

J'aimerais lancer une recherche dans ma boite mail via Excel

Pièce jointe 642693

Merci pour votre aide

Pièce jointe 642691

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
Sub SearchByAddress()
'---------------------------------------------------------------------------------------------------------------------
' Auteur : Oliv- adapté du code suivant http://www.slipstick.com/developer/instant-search-messages-selected-contact/
' Idée   : Trarc
' Date   : 23/06/2016
' OS_App : Win 8.1_OL-2007
' But    : Automatiser la commande "Rechercher tout/Message de l'expéd" pour trier rapidement les messages d'un dossier.
'---------------------------------------------------------------------------------------------------------------------
 
 'Vérifier l'ouverture de OUTLOOK :
     'Excel pratique par ouf746 » 26 janvier 2017, 15:08
       Dim oOutlook As Object
 
        On Error Resume Next
        Set oOutlook = GetObject(, "Outlook.Application")
        On Error GoTo 0
 
        If oOutlook Is Nothing Then
            Shell "Outlook.exe", vbHide
        End If
 '***
 
    Dim myOlApp As New Outlook.Application
    Dim ns As Outlook.Namespace
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
 
    Dim txtSearch As String
 
    Set ns = myOlApp.GetNamespace("MAPI")
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
 
    txtSearch = frmSaisie.txtEmail 'myOlSel.Item(1).SenderName
 
    myOlExp.Search txtSearch, olSearchScopeCurrentFolder
 
 'Mettre OUTLOOK devant
    'Excel pratique par fred2406 » 16 février 2018, 18:55
    Outlook.ActiveWindow.WindowState = 0
 
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
 
End Sub

17/08/2023, 11h32
halaster08

Bonjour,

Je pense que tu n'as pas activé la référence outlook
Dans l'interface vba dans le menu Outils -> reférence : coche la case microsoft outlook 16.0 object library

Avec ce code ça fonctionne

Code:

1
2
3
4
5
6
7
8
9
Sub Recherche_Outlook()
Dim OutlookApp As Object
Dim Recherche As String
    Recherche = "espace"
    Set OutlookApp = CreateObject("Outlook.Application")
    OutlookApp.ActiveWindow.Activate
    OutlookApp.ActiveExplorer.Search Recherche, olSearchScopeAllFolders
    Set OutlookApp = Nothing
End Sub

Problème lorsque Option Explicit est actif

Comment déclarer la variable : olSearchScopeAllFolders

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Option Explicit
Private Sub BT_Recherche_Outlook_Click()
Dim OutlookApp As Object
Dim Recherche As String
'Vérifier et ouvrir Outlook si pas ouvert
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OutlookApp Is Nothing Then
        Shell "Outlook.exe" ', vbHide
    End If
    Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value
    Set OutlookApp = CreateObject("Outlook.Application")
    OutlookApp.ActiveWindow.Activate
    OutlookApp.ActiveExplorer.Search Recherche, olSearchScopeAllFolders
    Set OutlookApp = Nothing
End Sub

25/09/2023, 17h48
Philippe Tulliez

1 pièce(s) jointe(s)

Bonjour,
olSearchScopeAllFolders est une constante Outlook elle est implicitement déclarée et a comme valeur 1.

Pièce jointe 644431

1 pièce(s) jointe(s)

Demande une déclaration

Pièce jointe 644433

Par contre, en remplaçant par 0, c'est tout bon

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Option Explicit
Private Sub BT_Recherche_Outlook_Click()
Dim OutlookApp As Object
Dim Recherche As String
'Vérifier et ouvrir Outlook si pas ouvert
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OutlookApp Is Nothing Then
        Shell "Outlook.exe" ', vbHide
    End If
    Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value
    Set OutlookApp = CreateObject("Outlook.Application")
    OutlookApp.ActiveWindow.Activate
    OutlookApp.ActiveExplorer.Search Recherche, 0 'https://learn.microsoft.com/en-us/office/vba/api/outlook.olsearchscope
    Set OutlookApp = Nothing
End Sub

25/09/2023, 18h21
goninph

2 pièce(s) jointe(s)

Autres détails

Le volet de la recherche reste ouvert, et je dois appuyer sur la touche Enter pour la fermer
Pièce jointe 644436

J'aimerais inverser le tri des résultats

Pièce jointe 644438
25/09/2023, 18h47
Philippe Tulliez

Bonjour,
Si le système indique variable non définie, cela signifie que la bibliothèque Outlook n'est pas référencée et que l'on est dans un cas de Late Binding
Il faut alors déclarer la variable ou une constante comme Byte, Integer ou Long avec comme valeur 1

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub BT_Recherche_Outlook_Click()
Dim OutlookApp As Object
Dim Recherche As String
Dim olSearchScope As Long
'Vérifier et ouvrir Outlook si pas ouvert
    On Error Resume Next
    Set OutlookApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OutlookApp Is Nothing Then
        Shell "Outlook.exe", vbMaximizedFocus  ', vbHide
    End If
    Recherche = "espace"
'    Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value
    Set OutlookApp = CreateObject("Outlook.Application")
    OutlookApp.ActiveWindow.Activate
    olSearchScope = 0
    OutlookApp.ActiveExplorer.Search Recherche, olSearchScope 'https://learn.microsoft.com/en-us/office/vba/api/outlook.olsearchscope
    Set OutlookApp = Nothing
End Sub

27/09/2023, 14h31
goninph

Bonjour,

Le code fonctionne nickel, mais si je suis dans mon calendrier la recherche va s'effectuer dans le calendrier et de même si je suis dans les Tâches la recherche va s'effectuer dans les tâches

Comment choisir la boite de réception du compte p.gonin@zurbuchensa.ch pour effectuer la recherche ?

Je vous remercie pour votre aide 😘
27/09/2023, 15h20
Philippe Tulliez

Bonjour,

Citation:

Comment choisir la boite de réception du compte p.gonin@zurbuchensa.ch pour effectuer la recherche ?

Le deuxième argument de la méthode Search indique où doit avoir lieu la recherche 1 (olSearchScopeAllFolders) c'est partout (voir l'illustration de ma réponse fil )
27/09/2023, 17h29
goninph

Oui, j'ai vu, mais quoique je fasse le problème persiste

Deplus si j'ai l'agenda d'un autre collaborateur est ouvert, la recherche va s'effectuer dans l'agenda du collaborateur
27/09/2023, 22h44
Philippe Tulliez

Bonjour,
Vous avez sans doute Exchange pour lequel je n'ai aucune compétence.
28/09/2023, 17h07
goninph

Personne à une idée ?

Bonjour,

Voilà ça fonctionne, la recherche s'ouvre dans une nouvelle fenêtre et le volet des dossiers sur la gauche est réduit ce qui laisse plus de place pour la lecture, coup de bol

Par contre, je n'arrive toujours pas à maximiser cette nouvelle fenêtre, un truc de fou

Merci pour votre aide

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
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
    '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 = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & "." & Extension
    Else
        Position_du_Point = InStr(Extension, ".")
        If Position_du_Point = 0 Then
            Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & " " & Cells(ActiveCell.Row, Range("TS_Suivi" & "[Fournisseur]").Column).Value
        Else
            Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & "." & Right(Extension, Len(Extension) - Position_du_Point)
        End If
    End If
    Set Messagerie = CreateObject("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.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
    Set Messagerie = Nothing
    Unload Me
End Sub

Enfin !

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
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 = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & "." & Extension
    Else
        Position_du_Point = InStr(Extension, ".")
        If Position_du_Point = 0 Then
            Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & " " & Cells(ActiveCell.Row, Range("TS_Suivi" & "[Fournisseur]").Column).Value
        Else
            Recherche = Cells(ActiveCell.Row, Range("TS_Suivi" & "[Cmde]").Column).Value & "." & Right(Extension, Len(Extension) - Position_du_Point)
        End If
    End If
    Set Messagerie = CreateObject("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
    Set Messagerie = Nothing
Application.ScreenUpdating = True
End Sub

04/03/2024, 20h42
goninph

Bonjour,

Impossible de trier les résultats de la recherche avec le mail le plus récent en haut de l'affichage

Une idée ?

Meilleures salutations
29/09/2024, 07h05
goninph

Toujours pas de solution ?