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
Partager