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 163 164 165 166 167 168 169 170 171
|
Sub ExportFolderItemsToExcel()
'---------------------------------------------------------------------------------------
' Procedure : ExportFolderItemsToExcel
' Author : Oliv
' Date : 10/11/2017
' Purpose : export des informations d'Emails de la boite de réception 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
Dim DerniereColonne As Long
Const olFolderInbox = 6
Const olUserItems = 0
Dim OL As Object
Dim Destination As Range
On Error GoTo FinOutLook
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
Debug.Print oFolder.Name
'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
If oTable.GetRowCount = 0 Then
MsgBox "Aucun message dans la boite de messagerie !", vbInformation
Exit Sub
End If
Set Wk = ActiveWorkbook
Set Ws = Wk.Sheets("Mails") ' Nom de l'onglet à adapter
With Ws
R = 11 '.Cells(.Rows.Count, 1).End(xlUp).Row + 1 'Chez moi les tableaux commencent toujours à la ligne 10
End With
'GoTo parcourir
' one row spanning several columns
oTable.Sort "ReceivedTime", True
arr = oTable.GetArray(oTable.GetRowCount)
Set Destination = Ws.Range("a" & R)
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 écrit 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")
Select Case I
Case 2
Ws.Cells(R, I).Value = Format(oRow(oTable.Columns(I).Name), "mm/dd/yyyy") ' hh:mm:ss")
Case Else
Ws.Cells(R, I).Value = oRow(oTable.Columns(I).Name)
End Select
Next I
Set oRow = Nothing
R = R + 1
Loop
GoTo mef
mef:
'mise en forme
With Ws
With .Cells
' .AutoFilter
.EntireColumn.AutoFit
End With
DerniereColonne = .Cells(10, .Columns.Count).End(xlToLeft).Column
With .Range(.Cells(10, 1), .Cells(10, DerniereColonne)).Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
.Parent.Font.Bold = True
End With
.Cells.WrapText = False
.Activate
End With
GoTo FinOutLook
FinOutLook:
Set OL = Nothing
Set Wk = Nothing
Set Ws = Nothing
Set oTable = Nothing
Set oRow = Nothing
Set Destination = Nothing
Set ShListe = Nothing
Exit Sub
End Sub |
Partager