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
| Option Explicit
Dim ri As Long
Private Sub CommandButton1_Click()
ri = 2
Dim app As Outlook.Application
Dim AppNs As Outlook.Namespace
Dim AppFolder As Outlook.MAPIFolder ' MAPIFolder
Set app = New Outlook.Application
Set AppNs = app.GetNamespace("MAPI")
Set AppFolder = AppNs.Folders.Item("dossier 2012") '.Folders.Item("Ma Recherche")
Call ProcessFolder(AppFolder)
Set AppFolder = Nothing
Set AppNs = Nothing
' app.Quit
Set app = Nothing
End Sub
Sub ProcessFolder(AppFolder As Outlook.MAPIFolder)
Dim email As Outlook.MailItem
Dim obj As Object
Dim AppSubFolder As Outlook.MAPIFolder 'Outlook.Folders
For Each AppSubFolder In AppFolder.Folders
Cells(ri, 1).Value = AppSubFolder.Name
ri = ri + 1
ProcessFolder AppSubFolder
Next AppSubFolder
' On Error Resume Next
For Each obj In AppFolder.Items
If TypeOf obj Is Outlook.MailItem Then
Set email = obj
Cells(ri, 2).Value = email.ReceivedTime
Cells(ri, 3).Value = email.SenderEmailAddress
Cells(ri, 4).Value = email.Subject
Cells(ri, 5).Value = email.CC
Cells(ri, 6).Value = email.Body
If email.Attachments.Count > 0 Then
Dim ci As Integer
ci = 1
Dim emailAttachement As Outlook.Attachment
For Each emailAttachement In email.Attachments
Cells(ri, 6 + ci).Value = emailAttachement.Filename
ci = ci + 1
Next emailAttachement
End If
ri = ri + 1
End If
Next
End Sub |
Partager