Bonjour,

Je souhaite scanner les mails d'une boite générique sous Outlook, en VBA.
J'y arrive très lorsque que je dois scanner ma boite mail pro, mais pas sur une boite générique auquel j'ai accès.
J'ai chercher sur différents forum et différents moteur de recherche, mais je n'ai rien trouvé.
Savez vous s'il est possible de le faire ?

Ci joint le code que j'utilise pour scanner ma boite pro, j'ai naïvement penser qu'il suffisait de mettre l'adresse mail de la boite générique à la place de la mienne.

Merci pour votre aide

Code :Sélectionner tout -Visualiser dans une fenêtre à part
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
Sub Enregistreobjetmail()
    'Enregistre l'objet d'un mail et récupère la date
    'Sélectionner auparavant l'option : OUTILS -Référence - Microsoft Outlook ...Library
 
Dim Base As Workbook
Dim BDD As Worksheet
Dim Test As String
 
Set Base = ThisWorkbook
Set BDD = Base.Worksheets("BDD")
 
 
Contact = "monadressepro@domaine.fr"
'Contact = Range("Z1")
 
'Enleve les message d'alerte
Application.DisplayAlerts = False
Application.ScreenUpdating = False
 
    'Déclarations
    Dim olApp As Object
    Dim NS As Object
    Dim dossier As Object
    Dim dossier2 As Object
    Dim i As Object
    Dim pceJointe As Outlook.Attachment
    Dim Tour As Integer
 
    'Affectations
    Set olApp = CreateObject("Outlook.Application")         'L'applicatif Outlook
    Set NS = olApp.GetNamespace("MAPI")                         'Les noms des dossiers
 
 
    'Le 1er dossier de la boîte de réception
    Set dossier = NS.Folders(Contact).Folders("Boîte de réception") '.Folders("A traiter")
    'Set Dossier = NS.Folders(1).Folders("Boîte de réception").Folders(1)
 
    On Error Resume Next
    Set dossier2 = NS.Folders(Contact).Folders("Boîte de réception")
    Dim myNewFolder As MAPIFolder
    Set myNewFolder = dossier2.Folders.Add("Archive résa Mobicar")
 
    Set dossier2 = NS.Folders(Contact).Folders("Boîte de réception") '.Folders("Archive résa Mobicar")
 
    'Pour chaque mail dans l'ensemble des mails du dossier
    Tour = 1
    For Each i In dossier.Items
        If i.SenderName = "noreply@chevincomputers.com" Then
            'Range("K1") = i.Subject
            Test = InStr(i.Subject, "[Mobicar] Réservation approuvée :")
            If Test <> 0 Then
                BDD.Range("A" & Tour) = i.Subject 'affiche l'objet du mail
                BDD.Range("B" & Tour) = i.Body 'affiche le corps du mail
                Tour = Tour + 1
                'i.Move dossier2
            End If
        End If
    Next
If BDD.Range("A1") = "" Then
Exit Sub
Else
Call Recup_info_mail
End If
 
'Enleve les message d'alerte
Application.DisplayAlerts = True
Application.ScreenUpdating = True
 
End Sub