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
| Option Explicit
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)
'si on veut choisir
Set oFolder = OL.Session.PickFolder
criteria = "[MessageClass]='IPM.Note' or [MessageClass]='IPM.Post'"
Set oTable = oFolder.GetTable(criteria, olUserItems)
On Error Resume Next
With oTable.Columns
''.Add ("Duration") 'KO
''.Add ("Type") 'KO
.Add ("ReceivedTime")
.Add ("Senton")
.Add ("Size")
.Add ("To")
.Add ("Cc")
.Add ("Bcc")
.Add ("Categories")
.Add ("ConversationTopic")
.Add ("ReceivedByName")
.Add ("SenderName")
''.Add ("Sent") 'KO
.Add ("SenderEmailAddress")
.Add ("Unread")
.Add ("http://schemas.microsoft.com/mapi/proptag/0x0E1B000B") 'PR_HASATTACH
.Add ("ConversationIndex")
.Add ("http://schemas.microsoft.com/mapi/proptag/0x1000001F") '="Body"
End With
'MsgBox oTable.GetRowCount
Dim AppExcel As Object
Dim Wk As Object, Ws As Object
Set AppExcel = CreateObject("Excel.application")
AppExcel.Visible = True
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/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 |
Création de tableau de bord à partir d'outlook
Répondre avec citation
Oliv'
Partager