Exporter dans un fichier excel tous les sujets d'email contenus dans sous fichier outlook

**totor92290** · 25/05/2017, 11h37

**totor92290** · 25/05/2017, 12h27

J'ai trouvé ce super code.

Par contre il ne me "remonte" que les mails reçu du jour, or il me faudrait l'intégralité du contenu du folder.

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
Sub ExportFolderItemsToExcel()
'---------------------------------------------------------------------------------------
' Procedure : ExportFolderItemsToExcel
' Author    : Oliv
' Date      : 04/11/2016
' Purpose   :
'---------------------------------------------------------------------------------------
'
    Dim oFolder As Outlook.Folder
    Dim criteria
    Dim oTable As Table
    Dim i, oRow, r, arr
    'Si on connait le nom
   'Set oFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders("A")
 
    'si on veut choisir
Set oFolder = Application.Session.PickFolder
 
    criteria = "[MessageClass]='IPM.Note' or [MessageClass]='IPM.Post'"
 
    criteria = "[MessageClass]='IPM.Note'  and [LastModificationTime] > '" & Date & "'"
    Set oTable = oFolder.GetTable(criteria, olUserItems)
 
 
    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(i).Name
    Next i
    Ws.Range("A:B").NumberFormat = "@"
    Ws.Range("C:D").NumberFormat = "General"
 
    '     one row spanning several columns
    oTable.Sort ("LastModificationTime")
    arr = oTable.GetArray(oTable.GetRowCount)
 
    Dim Destination As Object
    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 MsgBox "Une erreur est intervenue"
    'quand cela ne marche pas cela vient du format de la colonne destination
    On Error GoTo 0
    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
 
 
End Sub