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
| Private Sub Mails_contactsOutlook()
Dim olApp As Outlook.Application
Dim Cible As Outlook.ContactItem
Dim dossierContacts As Outlook.MAPIFolder
Dim Dossier As Outlook.MAPIFolder
Dim Ns As Outlook.Namespace
Set olApp = New Outlook.Application
Set dossierContacts = olApp.GetNamespace("MAPI").GetDefaultFolder(olFold erContacts)
Set Ns = olApp.GetNamespace("MAPI")
Set Dossier = Ns.Folders("Projets").Folders("Process") " ça bloque ici car il ne trouve pas le répertoire !!??"
SearchFolders Dossier
End Sub
Private Sub SearchFolders(ByVal Fld As Outlook.MAPIFolder)
Dim OLmail As Outlook.MailItem
Dim SousDossier As Outlook.MAPIFolder
Dim c As Range, start As Long, trouv As Long, msg As String
On Error Resume Next
For Each SousDossier In Fld.Folders
If UCase(SousDossier.Name) = "Process" Then
For Each OLmail In SousDossier.Items
a = Range("A" & Cells.Rows.Count).End(xlUp)(2, 1).Row
Range("A" & a) = OLmail.Subject
Range("B" & a) = OLmail.SenderName
Range("C" & a) = OLmail.CreationTime
Range("D" & a) = OLmail.Body
Next OLmail
SearchFolders SousDossier
End If
Next SousDossier
End Sub
Sub start()
If [A2] <> "" Then Range("A2:B" & Range("B" & Cells.Rows.Count).End(xlUp).Row).Clear
With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
Mails_contactsOutlook
[A2].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[B2], Order2:=xlAscending, Header:=xlYes
With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
End Sub |
Partager