XL 2016 Macro extraction mail

[Antoine98]

Bonjour,

J'ai fait une macro pour extraire mes différentes boites mails à J-1 dans un dossier bien précis néanmoins j'ai un problème pour le vendredi, puisque c'est à J-1.Merci d'avance pour vos réponses.Voici le code qui a été créé:

Dim nbitems
Dim WS As Object
Dim R

Sub ExtractionTotale()
'---------------------------------------------------------------------------------------
' Procedure : ListSubFolders
' Author : OLIV
' Date : 02/02/2018
'---------------------------------------------------------------------------------------

Dim t1 As Double, t2 As Double


Dim olFolder As Outlook.Folder

Dim OL As Object
If UCase(Application) = "OUTLOOK" Then
Set OL = Application
Else
Set OL = CreateObject("outlook.application")
End If

'si on veut choisir le dossier
'Set olFolder = OL.Session.PickFolder'


'Si on connait le dossier (ici boite par defaut complète)
'Set olFolder = OL.Session.GetDefaultFolder(olFolderInbox).Parent


Set myNameSpace = Application.GetNamespace("MAPI")

Dim nom
Dim nom2
Dim strDate

Dim p 'variable pour vendredi
p = 0

If Weekday(Now, vbMonday) Then p = 2

strDate = Format(Date - 1 - p, "dd-mm-yy")


Dim i
For i = 1 To 4
Select Case i
Case 1
Set olFolder = myNameSpace.Folders("XXX").Folders("Boîte de réception")
nom2 = "XXX" & " " & strDate
nom = "C:\Users\USER\Desktop\XXX\"

Case 2
Set olFolder = myNameSpace.Folders("XXX").Folders("Boîte de réception")
nom2 = "XXX" & " " & strDate
nom = "C:\Users\USER\Desktop\XXX\"

Case 3
Set olFolder = myNameSpace.Folders("XXX").Folders("Boîte de réception")
nom2 = "FONDS Ordres" & " " & strDate
nom = "C:\Users\USER\Desktop\XXX\"

Case 4
Set olFolder = myNameSpace.Folders("XXX").Folders("Boîte de réception")
nom2 = "XXX" & " " & strDate
nom = "C:\Users\USER\Desktop\XXX\"

End Select

nbitems = 0

t1 = Time
t2 = Timer

Dim AppExcel As Object
Dim Wk 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 = AppExcel.Workbooks.Add

Set WS = Wk.ActiveSheet



WS.Cells(1, 1).Value = "Subject"
WS.Cells(1, 2).Value = "ReceivedTime"
WS.Cells(1, 3).Value = "To"
WS.Cells(1, 4).Value = "CC"
WS.Cells(1, 5).Value = "SenderName"
WS.Cells(1, 6).Value = "Body"
R = 2
ProcessFolder olFolder


WS.SaveAs Filename:=nom & nom2


'clear all the variables
Set WS = Nothing
Set Wk = Nothing
Set AppExcel = Nothing



Next
excel.Application.Quit
MsgBox "Time:" & t1 & vbCr & CStr(Time - t1) & vbCr & "Timer:" & t2 & vbCr & Format(Timer - t2, "0.000") & vbCr & Timer - t2 & vbCr & nbitems & " traités"
End Sub


Sub ProcessFolder(StartFolder As Outlook.MAPIFolder)
' en cas d'erreur veuillez ajouter une référrence à "Microsoft OUTLOOK 1X.0 Object Library"
Dim p 'variable pour vendredi
p = 0

If Weekday(Now, vbMonday) Then p = 2


Dim objFolder As Outlook.MAPIFolder
Dim objItem As Outlook.MailItem
On Error Resume Next
DoEvents
' do something specific with this folder
nbitems = nbitems + StartFolder.Items.Count

' process all the items in this folder
For Each objItem In StartFolder.Items

'Get all Mails from the 2 previous months


If DatePart("d", Date - 60 - p) = DatePart("d", objItem.ReceivedTime) And DatePart("m", Date - 60 - p) = DatePart("m", objItem.ReceivedTime) And DatePart("y", Date - 60 - p) = DatePart("y", objItem.ReceivedTime) Then


WS.Cells(R, 1).Value = objItem.Subject
WS.Cells(R, 2).Value = objItem.ReceivedTime
WS.Cells(R, 3).Value = objItem.To
WS.Cells(R, 4).Value = objItem.CC
WS.Cells(R, 5).Value = objItem.SenderName
WS.Cells(R, 6).Value = objItem.Body
' etc..
R = R + 1

End If


Next

' process all the subfolders of this folder
For Each objFolder In StartFolder.Folders
Call ProcessFolder(objFolder)
Next



Set objFolder = Nothing
End Sub