Utilisation de Namespace.Folder

Citation:
Envoyé par Airahn
Bonjour,

J'utilise ce code d'Oliv (que je salue). Regardez s'il peut vous convenir :
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
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
150
151
152
153
154
155
156
157
158
159
160
161
162
 
 
 
Sub M004_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
    Dim Wk As Workbook
    Dim Ws As Worksheet
 
    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 = ActiveWorkbook 'AppExcel.Workbooks.Add
    Set Ws = Wk.Sheets("Liste des mails") '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")
            Ws.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
 
    Ws.Activate
 
    Set OL = Nothing
    Set Wk = Nothing
    Set Ws = Nothing
    Set oTable = Nothing
    Set oRow = Nothing
    Set Destination = Nothing
 
 
    Exit Sub
 
End Sub