récupérer les données d'outlook avec VBA excel

Version imprimable

13/02/2012, 15h57
the-malco

récupérer les données d'outlook avec VBA excel

Bonjour,

Mon problème est le suivant : au fait, je dois récupérer dans un fichier excel les données des mails d'outlook (expéditeur, destinataires, object, corps du mail, nom de la pièce jointe) et cela dans tous les répertoires et sous répertoires d'outlook (j'ai 6 répertoires dans lesquels il y a 5 niveaux de sous répertoires). n'ayant jamais travaillé sur outlook via vba excel, je cherche depuis le matin sur internet et je ne trouve pas mon bonheur :(.

L'histoire des sous répertoires est très importante, car l'objectif est de pouvoir parcourir et récupérer les données dans tous les dossiers d'outlook ...

Merci d'avance pour votre aide docteurs :)

Bonsoir,

Un début de piste pour une recherche dans :
- dossier personnel nommé "Dossier 2011"
- un sous-dossier nommé "Ma Recherche"

Malheureusement j'ai une erreur sur la boucle des mails For Each email In AppFolder.Items qui m'oblige à utiliser
un très laid On Error Resume Next.
Et par conséquent la liste des mails doit être incomplète ...

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
56
57
Option Explicit
 
Dim ri As Long
 
Private Sub CommandButton1_Click()
 
  ri = 2
 
  Dim app As Outlook.Application
  Dim AppNs As Outlook.Namespace
  Dim AppFolder As Outlook.MAPIFolder  '  MAPIFolder
 
  Set app = New Outlook.Application
  Set AppNs = app.GetNamespace("MAPI")
  Set AppFolder = AppNs.Folders.Item("Dossier 2011") .Folders.Item("Ma Recherche")
 
  Call ProcessFolder(AppFolder)
 
 Set AppFolder = Nothing
  Set AppNs = Nothing
 ' app.Quit
  Set app = Nothing
End Sub
 
Sub ProcessFolder(AppFolder As Outlook.MAPIFolder)
 
    Dim email As Outlook.MailItem
 
    Dim AppSubFolder As Outlook.Folders 'MAPIFolder
 
    For Each AppSubFolder In AppFolder.Folders
        Cells(ri, 1).Value = AppSubFolder.Name
        ri = ri + 1
        ProcessFolder AppSubFolder
    Next AppSubFolder
 
    On Error Resume Next
    For Each email In AppFolder.Items
        Cells(ri, 2).Value = email.ReceivedTime
        Cells(ri, 3).Value = email.SenderEmailAddress
        Cells(ri, 4).Value = email.Subject
        Cells(ri, 5).Value = email.CC
        Cells(ri, 6).Value = email.Body
 
        If email.Attachments.Count > 0 Then
            Dim ci As Integer
            ci = 1
            Dim emailAttachement As Outlook.Attachment
            For Each emailAttachement In email.Attachments
                Cells(ri, 6 + ci).Value = emailAttachement.Filename
                ci = ci + 1
            Next emailAttachement
        End If
 
        ri = ri + 1
    Next
End Sub

14/02/2012, 03h11
kiki29

Salut, voir dans la FAQ http://excel.developpez.com/faq/?page=Messagerie
15/02/2012, 06h45
AlainTech

Citation:

Envoyé par BlueMonkey

Malheureusement j'ai une erreur sur la boucle des mails For Each email In AppFolder.Items qui m'oblige à utiliser
un très laid On Error Resume Next.
Et par conséquent la liste des mails doit être incomplète ...

Bonjour,

La raison en est que tu n'as pas que des mails dans ce dossier.
Par exemple, des "Meeting request"...

Bonjour,

Effectivement, en reprenant le code en prenant en compte le qu'il n'y avait pas que des mails dans le dossier,
on peut retirer le On Error Resume Next.

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
56
57
58
59
60
61
Option Explicit
 
Dim ri As Long
 
Private Sub CommandButton1_Click()
 
  ri = 2
 
  Dim app As Outlook.Application
  Dim AppNs As Outlook.Namespace
  Dim AppFolder As Outlook.MAPIFolder  '  MAPIFolder
 
  Set app = New Outlook.Application
  Set AppNs = app.GetNamespace("MAPI")
  Set AppFolder = AppNs.Folders.Item("dossier 2012") '.Folders.Item("Ma Recherche")
 
  Call ProcessFolder(AppFolder)
 
 Set AppFolder = Nothing
  Set AppNs = Nothing
 ' app.Quit
  Set app = Nothing
End Sub
 
Sub ProcessFolder(AppFolder As Outlook.MAPIFolder)
 
    Dim email As Outlook.MailItem
    Dim obj As Object
 
    Dim AppSubFolder As Outlook.MAPIFolder 'Outlook.Folders
 
    For Each AppSubFolder In AppFolder.Folders
        Cells(ri, 1).Value = AppSubFolder.Name
        ri = ri + 1
        ProcessFolder AppSubFolder
    Next AppSubFolder
 
   ' On Error Resume Next
    For Each obj In AppFolder.Items
        If TypeOf obj Is Outlook.MailItem Then
           Set email = obj
           Cells(ri, 2).Value = email.ReceivedTime
           Cells(ri, 3).Value = email.SenderEmailAddress
           Cells(ri, 4).Value = email.Subject
           Cells(ri, 5).Value = email.CC
           Cells(ri, 6).Value = email.Body
 
           If email.Attachments.Count > 0 Then
               Dim ci As Integer
               ci = 1
               Dim emailAttachement As Outlook.Attachment
               For Each emailAttachement In email.Attachments
                   Cells(ri, 6 + ci).Value = emailAttachement.Filename
                   ci = ci + 1
               Next emailAttachement
           End If
 
           ri = ri + 1
        End If
    Next
End Sub

15/02/2012, 10h16
the-malco

Merci beaucoup pour votre réponse. Par contre j'ai 2 questions :
1/ à quoi correspondent les 2 dossiers : "dossier 2012" et "Ma recherche" ?
2/ est-ce que le code lit systematiquement dans tous les dossiers et sous dossiers (il y a 5 niveaux de sous dossiers) ?

Merci beaucoup

Malco
15/02/2012, 10h28
BlueMonkey
Bonjour,

Citation:

1/ à quoi correspondent les 2 dossiers : "dossier 2012" et "Ma recherche" ?

Le dossier 2012 est le nom du fichier personnel contenant les emails.
"Ma recherche" est un sous-dossier de ce dossier personnel.

Citation:

2/ Est-ce que le code lit systematiquement dans tous les dossiers et sous dossiers (il y a 5 niveaux de sous dossiers) ?

Oui. ProcessFolder est une fonction récursive.
Code:

1 2 3 4 5 6 7 Sub ProcessFolder(AppFolder As Outlook.MAPIFolder) '... For Each AppSubFolder In AppFolder.Folders '... ProcessFolder AppSubFolder '... Next AppSubFolder