VBA Excel / Récupérer des mails OUTLOOK dans une boite mail qui n'est pas celle par défaut

**GregCompta** · 26/05/2018, 02h39

Bonjour,

Comme indiqué dans le titre, je cherche à récupérer sur Outlook des données d'une boite de réception d'un de mes comptes. J'aimerais plus exactement basculer dans chacun de mes comptes, pour récupérer toutes les données qui m'intéresse dans chaque "Boite de réception". Je pense que mon code est quasi terminé (car ça fonctionnait très bien avant d'ajouter d'autres comptes dans Outlook : 2).

Voici mon fichier en pj (si besoin); et mon code ci-dessous.

J'ai trouvé une possibilité avec la méthode .createrecipient(...) mais même office n'offre pas les renseignements nécessaires à sa bonne exécution. C'est vraiment désolant de voir que les créateurs de ces supers logiciels ne sont d'aucune utilité.

En vous remerciant profondément du temps consacré à la résolution de ce soucis bien embêtant.

Pour info, je suis sur Excel 2016.

Permettant de lancer l'importation :

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
Sub ImportationPJ()
Dim Ws As Worksheet
Dim Compte As String, WsI As Integer
    Compte = ThisWorkbook.ActiveSheet.Name
    WsI = ThisWorkbook.ActiveSheet.Index - 1
Select Case Compte
    Case "TdB"
        For Each Ws In ThisWorkbook
            If Ws.Name <> "TdB" Then
                Call Import_Pj(Compte, WsI)
            End If
        Next
    Case Else
        Call Import_Pj(Compte, WsI)
End Select
End Sub

Code d'importation des données Outlook :

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
 
Sub Import_Pj(Compte As String, WsI As Integer)
'Importations des PJ d'Outlook et de ses infos mail
Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application
Dim olNameSpace As Outlook.Namespace
    Set olNameSpace = olApp.GetNamespace("MAPI")
'    Dim myRecipient As Outlook.Recipient
'    Set myRecipient = olNameSpace.CreateRecipient(Compte)
    Dim olDossier As Outlook.Folder
        Set olDossier = olNameSpace.Folders(WsI).Folders(olFolderInbox)
'        Set olDossier = olNameSpace.GetDefaultFolder(myRecipient).Folders(olFolderInbox)
    Dim oMail As Object
    Dim PieceJointe As Outlook.Attachment
    Dim ligne As Long, compteur As Integer
    Dim iType As String
 
Application.ScreenUpdating = False
 
ligne = 3
With ThisWorkbook.Sheets(Compte)
If .Range("A" & ligne).Value <> "" Then .Range("Tableau" & WsI).Delete
 
    For Each oMail In olDossier.Items
        iType = TypeName(oMail)
        If iType = "MailItem" Or iType = "MeetingItem" Then
            compteur = 1
 
            If oMail.Attachments.Count > 0 Then
                For Each PieceJointe In oMail.Attachments
                    .Cells(ligne, 1).Value = oMail.SentOn
                    .Cells(ligne, 2).Value = oMail.SenderEmailAddress
                    .Cells(ligne, 3).Value = oMail.Subject
                    .Cells(ligne, 4).Value = PieceJointe.Filename
                    .Cells(ligne, 5).Value = compteur
                compteur = compteur + 1
                ligne = ligne + 1
                Next
            End If
 
        End If
    Next
 
End With
 
    Set olApp = Nothing
    Set olNameSpace = Nothing
    Set olDossier = Nothing
    Set oMail = Nothing
 
ThisWorkbook.RefreshAll
Application.ScreenUpdating = True
 
End Sub

Encore merci

**GregCompta** · 27/05/2018, 13h05

APRES PLUSIEURS JOURS DE RECHERCHE, si ça peut aider...

Hello,

J'ai ajouté ces lignes qui me permettent d'extraire les informations des Pj dans chacune de mes boites de réception (pour chacun de mes comptes) ET CELA FONCTIONNE NICKEL (!) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Set MaBoite = olNameSpace.Stores(Compte)
Set olDossier = MaBoite.GetDefaultFolder(olFolderInbox)

Ma macro :

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
70
71
72
73
74
75
76
77
78
79
80
81
'Défini la boite qui doit être rafraîchie : 1 seule ou toutes
Sub ImportationPJ()
Dim Ws As Worksheet
Dim Compte As String, WsI As Integer
Compte = ThisWorkbook.ActiveSheet.Name
WsI = ThisWorkbook.ActiveSheet.Index - 1
Select Case Compte
    Case "TdB" 'Si je suis sur la page Tableau de Bord où sont répertoriés mes PJ en fonction de mes besoins
        For Each Ws In ThisWorkbook.Worksheets
            If Ws.Name <> "TdB" Then
                Compte = Ws.Name
                WsI = Ws.Index - 1
                Call Import_Pj(Compte, WsI)
            End If
        Next
    Case Else 'Si je suis sur l'une des feuilles correspondant à une boite en particulier (ex : Feuil(2) = BoiteMail(2)
        Call Import_Pj(Compte, WsI) 'Va chercher les infos et les intègre au tableau spécifique
End Select
End Sub

'Macro qui m'extrait les informations PJ selon le compte voulu
Sub Import_Pj(Compte As String, WsI As Integer)
'Importations des PJ d'Outlook et de ses infos mail
Dim olApp As Outlook.Application
    Set olApp = New Outlook.Application
Dim olNameSpace As Outlook.Namespace
    Set olNameSpace = olApp.GetNamespace("MAPI")
Dim olDossier As Outlook.Folder

Dim MaBoite As Store 'ici se trouve les 3 lignes 1/3
    Set MaBoite = olNameSpace.Stores(Compte) 'ici se trouve les 3 lignes 2/3
    Set olDossier = MaBoite.GetDefaultFolder(olFolderInbox) 'ici se trouve les 3 lignes 3/3

Dim oMail As Object
Dim PieceJointe As Outlook.Attachment
Dim ligne As Long, compteur As Integer
Dim iType As String
Application.ScreenUpdating = False
ligne = 3
With ThisWorkbook.Sheets(Compte)
If .Range("A" & ligne).Value <> "" Then .Range("Tableau" & WsI).Delete
    For Each oMail In olDossier.Items
        iType = TypeName(oMail)
        If iType = "MailItem" Or iType = "MeetingItem" Then
            compteur = 1
            If oMail.Attachments.Count > 0 Then
                For Each PieceJointe In oMail.Attachments
                    .Cells(ligne, 1).Value = oMail.SentOn
                    .Cells(ligne, 2).Value = oMail.SenderEmailAddress
                    .Cells(ligne, 3).Value = oMail.Subject
                    .Cells(ligne, 4).Value = PieceJointe.Filename
                    .Cells(ligne, 5).Value = compteur
                compteur = compteur + 1
                ligne = ligne + 1
                Next
            End If
        End If
    Next
End With
Call Tri(Compte, WsI)
    Set olApp = Nothing
    Set olNameSpace = Nothing
    Set olDossier = Nothing
    Set oMail = Nothing
ThisWorkbook.RefreshAll
Application.ScreenUpdating = True
End Sub

'Me permet de trier mes tableaux
Sub Tri(Compte As String, WsI As Integer)
With ActiveWorkbook.Worksheets(Compte).ListObjects("Tableau" & WsI).Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("Tableau" & WsI & "[[#All],[Date]]"), SortOn:=xlSortOnValues, Order _
        :=xlDescending, DataOption:=xlSortNormal
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub