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