Oliv-

Exportation Hyper rapide des infos des Emails vers Excel

Noter ce billet

1 Commentaire

par

Oliv-

, 17/04/2018 à 21h19 (5262 Affichages)

##########################################################
les codes ci-dessous peuvent être copiés soit dans EXCEL
il faut ajouter une référence soit à Microsoft Outlook 1x.0 Object Library
soit dans OUTLOOK et il faut ajouter la référence à Microsoft Excel 1x.0 Object Library
##########################################################

Voici plusieurs méthodes

On peut exporter les infos des Emails en parcourant le dossier mail par mail, ici avec tous les sous dossiers (traitement récursif)

Code vb :

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
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
Dim nbitems
Dim Ws As Object
Dim R
 
Sub ListSubFolders()
'---------------------------------------------------------------------------------------
' Procedure : ListSubFolders
' Author    : OLIV
' Date      : 02/02/2018
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim t1 As Double, t2 As Double
 
 
    Dim olFolder As Outlook.Folder
 
    Dim OL As Object
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    'si on veut choisir le dossier
    Set olFolder = OL.Session.PickFolder
 
    'Si on connait le dossier (ici boite par defaut complète)
    'Set olFolder = OL.Session.GetDefaultFolder(olFolderInbox).Parent
 
    nbitems = 0
 
    t1 = Time
    t2 = Timer
 
    Dim AppExcel As Object
    Dim Wk As Object
    If InStr(1, Application, "Excel", vbTextCompare) > 0 Then
        Set AppExcel = Application
    Else
        Set AppExcel = CreateObject("Excel.application")
        AppExcel.Visible = True
    End If
    Set Wk = AppExcel.Workbooks.Add
    Set Ws = Wk.ActiveSheet
 
    Ws.Cells(1, 1).Value = "Subject"
    Ws.Cells(1, 2).Value = "CreationTime"
    Ws.Cells(1, 3).Value = "LastModificationTime"
    Ws.Cells(1, 4).Value = "MessageClass"
    Ws.Cells(1, 5).Value = "ReceivedTime"
    Ws.Cells(1, 6).Value = "SentOn"
    Ws.Cells(1, 7).Value = "Size"
    Ws.Cells(1, 8).Value = "To"
    Ws.Cells(1, 9).Value = "CC"
    Ws.Cells(1, 10).Value = "BCC"
    Ws.Cells(1, 11).Value = "Categories"
    Ws.Cells(1, 12).Value = "ConversationTopic"
    Ws.Cells(1, 13).Value = "ReceivedByName"
    Ws.Cells(1, 14).Value = "SenderName"
    Ws.Cells(1, 15).Value = "SenderEmailAddress"
    Ws.Cells(1, 16).Value = "UnRead"
    Ws.Cells(1, 17).Value = "Attachments"
    Ws.Cells(1, 18).Value = "ConversationIndex"
    Ws.Cells(1, 19).Value = "EntryID"
    Ws.Cells(1, 20).Value = "Body"
    Ws.Cells(1, 21).Value = "FullFolderPath"
    R = 2
 
    ProcessFolder olFolder
 
    MsgBox "time:" & t1 & vbCr & CStr(Time - t1) & vbCr & "timer:" & t2 & vbCr & Format(Timer - t2, "0.000") & vbCr & Timer - t2 & vbCr & nbitems & " traités"
End Sub
 
 
Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
' en cas d'erreur veuillez ajouter une référrence à "Microsoft OUTLOOK 1X.0 Object Library"
    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Outlook.MailItem
    On Error Resume Next
    DoEvents
    ' do something specific with this folder
    nbitems = nbitems + StartFolder.Items.Count
 
    ' process all the items in this folder
    For Each objItem In StartFolder.Items
        Ws.Cells(R, 1).Value = objItem.Subject
        Ws.Cells(R, 2).Value = objItem.CreationTime
        Ws.Cells(R, 3).Value = objItem.LastModificationTime
        Ws.Cells(R, 4).Value = objItem.MessageClass
        Ws.Cells(R, 5).Value = objItem.ReceivedTime
        Ws.Cells(R, 6).Value = objItem.SentOn
        Ws.Cells(R, 7).Value = objItem.Size
        Ws.Cells(R, 8).Value = objItem.To
        Ws.Cells(R, 9).Value = objItem.CC
        Ws.Cells(R, 10).Value = objItem.BCC
        Ws.Cells(R, 11).Value = objItem.Categories
        Ws.Cells(R, 12).Value = objItem.ConversationTopic
        Ws.Cells(R, 13).Value = objItem.ReceivedByName
        Ws.Cells(R, 14).Value = objItem.SenderName
        Ws.Cells(R, 15).Value = objItem.SenderEmailAddress
        Ws.Cells(R, 16).Value = objItem.UnRead
        Ws.Cells(R, 17).Value = objItem.Attachments.Count > 0
        Ws.Cells(R, 18).Value = objItem.ConversationIndex
        Ws.Cells(R, 19).Value = objItem.EntryID
        Ws.Cells(R, 20).Value = objItem.Body
        Ws.Cells(R, 21).Value = StartFolder.FullFolderPath
        ' etc..
        R = R + 1
    Next
 
    ' process all the subfolders of this folder
    For Each objFolder In StartFolder.Folders
        Call ProcessFolder(objFolder)
    Next
 
    Set objFolder = Nothing
End Sub

Lorsque l'on n'a pas besoin d'informations sur les pièces jointes, on peut utiliser une méthode beaucoup plus rapide faisant appel à GetTable.

et ici au lieu de faire un traitement récursif, on va récupérer tous les Emails (et autres éléments) en utilisant un "DOSSIER DE RECHERCHE"
que j'ai créé en le nommant "tout"

aucun critère
Nom : tout.png
Affichages : 2821
Taille : 50,4 Ko

Nom : tout.png
Affichages : 2821
Taille : 50,4 Ko

https://support.office.com/fr-fr/art...9-0ccab0a56dc5

Il faut avant de lancer la macro cliquer sur le dossier de recherche en question et attendre sa mise à jour.

Code VB :

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
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
 
 
 
Sub ExportFolderItemsToExcel()
'---------------------------------------------------------------------------------------
' Procedure : ExportFolderItemsToExcel
' Author    : Oliv
' Date      : 10/11/2017
' Purpose   : export des informations d'Emails de la boite de reception vers excel
'---------------------------------------------------------------------------------------
'
    Dim oFolder As Object
    Dim criteria
    Dim oTable As Object
    Dim i, oRow, R, arr
 
    Const olFolderInbox = 6
    Const olUserItems = 0
 
    Dim OL As Object
    If UCase(Application) = "OUTLOOK" Then
        Set OL = Application
    Else
        Set OL = CreateObject("outlook.application")
    End If
 
    'Si on connait le nom
    Set oFolder = OL.Session.GetDefaultFolder(olFolderInbox).Store.GetSearchFolders.Item("tout")
 
    'si on veut choisir
    'Set oFolder = OL.Session.PickFolder
 
 
    'Pour ne prendre que les EMAILS
    'criteria = "[MessageClass]='IPM.Note' or [MessageClass]='IPM.Post'"
 
    'Pour tous les éléments
    criteria = "[MessageClass]<>'zzz'"
 
 
    Set oTable = oFolder.GetTable(criteria, olUserItems)
    MsgBox oTable.GetRowCount
    On Error Resume Next
    With oTable.Columns
        .RemoveAll
        .Add ("Subject")
        .Add ("CreationTime")
        .Add ("LastModificationTime")
        .Add ("MessageClass")
        .Add ("ReceivedTime")
        .Add ("Senton")
        .Add ("Size")
        .Add ("To")
        .Add ("Cc")
        .Add ("Bcc")
        .Add ("Categories")
        .Add ("ConversationTopic")
        .Add ("ReceivedByName")
        .Add ("SenderName")
        .Add ("SenderEmailAddress")
        .Add ("Unread")
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B")    'PR_HASATTACH
        .Add ("ConversationIndex")
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x66700102")
        .Add ("http://schemas.microsoft.com/mapi/proptag/0x1000001F")    '="Body"
        ''.Add ("Sent") 'KO
        ''.Add ("Duration") 'KO
        ''.Add ("Type") 'KO
 
    End With
    'MsgBox oTable.GetRowCount
 
    Dim AppExcel As Object
    Dim Wk As Object, Ws As Object
    If InStr(1, Application, "Excel", vbTextCompare) > 0 Then
        Set AppExcel = Application
    Else
        Set AppExcel = CreateObject("Excel.application")
        AppExcel.Visible = True
    End If
    Set Wk = AppExcel.Workbooks.Add
    Set Ws = Wk.ActiveSheet
 
    R = 2
    'Enumerate the table using test for EndOfTable
    For i = 1 To oTable.Columns.Count
        Ws.Cells(1, i).Value = oTable.Columns.Item(i).Name
        If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x0E1B000B" Then Ws.Cells(1, i).Value = "PR_HASATTACH"
        If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x66700102" Then Ws.Cells(1, i).Value = "EntryIdLong"
        If Ws.Cells(1, i).Value = "http://schemas.microsoft.com/mapi/proptag/0x1000001F" Then Ws.Cells(1, i).Value = "Body"
    Next i
    Ws.Cells.NumberFormat = "@"
    Ws.Range("C:H").NumberFormat = "General"
 
    'GoTo parcourir
    '     one row spanning several columns
    oTable.Sort "LastModificationTime", True
    arr = oTable.GetArray(oTable.GetRowCount)
 
    Dim Destination As Range
    Set Destination = Ws.Range("a2")
    Set Destination = Destination.Resize(UBound(arr, 1) + 1 - LBound(arr, 1), UBound(arr, 2) + 1 - LBound(arr, 2))
 
    On Error Resume Next
    Destination.Value = arr
 
    If Err = 1004 Then GoTo parcourir
    'quand cela ne marche pas cela vient du format de la colonne destination
    On Error GoTo 0
    GoTo mef
 
    'AUTRE METHODE on ecrit en parcourant les enregistrement et les colonnes
parcourir:
    'pour parcourir la table champs par champs
    oTable.MoveToStart
    Do Until (oTable.EndOfTable)
        On Error Resume Next
        Set oRow = oTable.GetNextRow()
        For i = 1 To oTable.Columns.Count
            Debug.Print oRow("Body")
            AppExcel.Cells(R, i).Value = oRow(oTable.Columns(i).Name)
        Next i
 
        R = R + 1
    Loop
 
    GoTo mef
 
mef:
 
    'mise en forme
    With Ws.Cells
        .AutoFilter
        .EntireColumn.AutoFit
    End With
 
    With Ws.Rows("1:1").Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
        .Parent.Font.Bold = True
    End With
    Ws.Cells.WrapText = True
    Ws.Cells.WrapText = False
    Exit Sub
 
End Sub