FrancisZheng
02-06-2017, 10:06 AM
Hello,
My program works fine. It just takes a lot of time when running.
Could anyone give me any advice on how to simplify it so that it can be quicker?
Thank you in advance.
' Ignore the comments, it's in french:)
Option Explicit
Public dd As Date, df As Date
Public dateFiltre As Date
Dim i As Long
Dim MailBoxName As String
Dim OlApp As Object
Dim olFolder As Outlook.Folder
Dim myNamespace As Outlook.Namespace
Dim cellDate As Range
Dim cellStatus As Range
Dim cellObject As Range
Dim cellDossier As Range
Dim cellCategory As Range
Dim cellCC As Range
Dim cellHour As Range
Dim cellExp As Range
Dim cellRecept As Range
Dim cellReadNotRead As Range
Dim cc As Long
Dim ch As Long
Dim ce As Long
Dim cr As Long
Dim crnr As Long
Dim cd As Long
Dim cs As Long
Dim co As Long
Dim ccat As Long
Dim cdir As Long
Dim nbLines As Long
Dim nbColumns As Long
Dim col As String
Dim nbRecu As Long
Dim nbSent As Long
Dim nbNoCat As Long
Dim nbNoCatOld As Long
Dim nbUnRead As Long
Dim inbox As Boolean
Dim env As Boolean
Dim del As Boolean
Dim minDate As String
Dim jour As String
Dim mois As String
Dim annee As String
'deux macros pour accelerer l execution de la macro principale:ini_sub et fin_sub
Public Sub ini_sub()
Application.ScreenUpdating = False 'rafraichissement ecran (pour ne pas voir défiler les macros)
Application.Calculation = xlCalculationManual ' supprime calcul auto EXCEL pour gagner du temps. A remettre dans fin_sub
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
End Sub
Public Sub fin_sub()
Application.ScreenUpdating = True 'rafrfraichissement ecran
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
Function LettreColonne(c As Long) As String
Dim reste As Long
Dim quotient As Long
quotient = Int(c / 26)
reste = c Mod 26
If quotient = 0 And reste = 0 Then
Exit Function
End If
If quotient = 0 Then
LettreColonne = Chr(64 + reste)
Else
If reste = 0 Then
quotient = quotient - 1
If quotient = 0 Then
LettreColonne = Chr(64 + 26)
Else
LettreColonne = Chr(64 + quotient) & Chr(64 + 26)
End If
Else
LettreColonne = Chr(64 + quotient) & Chr(64 + reste)
End If
End If
End Function
Sub Sous_Dossier(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim olFldr As Outlook.Folder
Dim sourceFolder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
j = 1
For Each Folder In olFolder.Folders
If Not Folder Is Nothing Then
'appel à la macro dossier
dossier Folder
Else
Exit Sub
End If
Next Folder
End Sub
Sub dossier(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim h As Date
Dim NumeroJour As Integer
Dim nomDos As String
Dim s As Boolean
'''''''''''''''''''
Dim cellCC As Range
Dim cellHour As Range
Dim cellExp As Range
Dim cellRecept As Range
Dim cellReadNotRead As Range
Dim cc As Long
Dim ch As Long
Dim ce As Long
Dim cr As Long
Dim crnr As Long
'''''''''''''''''''''''''''
j = 1
Set cellCC = ThisWorkbook.Worksheets("MAIN").Cells.Find("CC", lookat:=xlWhole)
cc = cellCC.Column
Set cellHour = ThisWorkbook.Worksheets("MAIN").Cells.Find("HOUR", lookat:=xlWhole)
ch = cellHour.Column
Set cellExp = ThisWorkbook.Worksheets("MAIN").Cells.Find("SENDER", lookat:=xlWhole)
ce = cellExp.Column
Set cellRecept = ThisWorkbook.Worksheets("MAIN").Cells.Find("RECEIVER", lookat:=xlWhole)
cr = cellRecept.Column
Set cellReadNotRead = ThisWorkbook.Worksheets("MAIN").Cells.Find("READ\NOTREAD", lookat:=xlWhole)
crnr = cellReadNotRead.Column
Set cellDate = ThisWorkbook.Worksheets("MAIN").Cells.Find("DATE", lookat:=xlWhole)
cd = cellDate.Column
Set cellDossier = ThisWorkbook.Worksheets("MAIN").Cells.Find("DOSSIER", lookat:=xlWhole)
cdir = cellDossier.Column
Set cellStatus = ThisWorkbook.Worksheets("MAIN").Cells.Find("STATUS", lookat:=xlWhole)
cs = cellStatus.Column
Set cellObject = ThisWorkbook.Worksheets("MAIN").Cells.Find("SUBJECT", lookat:=xlWhole)
co = cellObject.Column
Set cellCategory = ThisWorkbook.Worksheets("MAIN").Cells.Find("CATEGORY", lookat:=xlWhole)
ccat = cellCategory.Column
If olFolder.Items.Count > 0 Then
Do While True
If TypeOf olFolder.Items(j) Is MailItem Then
Set msg = olFolder.Items(j)
dateR = msg.ReceivedTime
d = Format(dateR, "dd/mm/yyyy")
h = Format(dateR, "hh:mm")
NumeroJour = Weekday(d, vbMonday)
'filtrer les mails ne pas afficher ceux reçus samedi ou dimanche
If d > dd And d < df And NumeroJour <> 6 And NumeroJour <> 7 Then
ThisWorkbook.Worksheets("MAIN").Cells(i, cd) = d
s = msg.Sent
ThisWorkbook.Sheets("MAIN").Cells(i, cdir).Value = msg.Parent.Name
ThisWorkbook.Sheets("MAIN").Cells(i, co).Value = msg.Subject
ThisWorkbook.Sheets("MAIN").Cells(i, ccat).Value = msg.Categories
ThisWorkbook.Sheets("MAIN").Cells(i, cc).Value = msg.cc
ThisWorkbook.Sheets("MAIN").Cells(i, ce).Value = msg.SenderName
ThisWorkbook.Sheets("MAIN").Cells(i, cr).Value = msg.ReceivedByName
ThisWorkbook.Sheets("MAIN").Cells(i, ch).Value = h
If msg.unRead = True Then
ThisWorkbook.Sheets("MAIN").Cells(i, crnr).Value = "Not Read"
nbUnRead = nbUnRead + 1
Else
ThisWorkbook.Sheets("MAIN").Cells(i, crnr).Value = "Read"
End If
If olFolder.Name = "Sent Items" Then
If s = True And d = dateFiltre Then
ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Sent"
nbSent = nbSent + 1
Else
ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Brouillon"
End If
Else
ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Received"
If d = dateFiltre Then
nbRecu = nbRecu + 1
End If
If olFolder.Name Like "Inbox" And msg.Categories Like "" Then
'compter le nbr de msg sans category recus a la date dateFiltre
nbNoCat = nbNoCat + 1
If nbNoCat = 1 Then
minDate = dateR
ElseIf nbNoCat > 0 Then
If dateR < minDate Then
minDate = dateR
End If
End If
End If
End If
i = i + 1
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
Else
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
End If
Else
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
End If
Loop
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_Dossier olFolder, dd, df
End Sub
'routine pour calculer le nombre de mails dans le dossier Sent Items
Sub DossierSent(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim nomDos As String
Dim s As Boolean
j = 1
If olFolder.Items.Count > 0 Then
Do While True
If TypeOf olFolder.Items(j) Is MailItem Then
Set msg = olFolder.Items(j)
dateR = msg.ReceivedTime
d = Format(dateR, "dd/mm/yyyy")
'filtrer les mails, compter ceux envoyes a la date d
If d = dateFiltre Then
If j = olFolder.Items.Count Then
If env Then
nbSent = nbSent + 1
End If
Exit Do
Else
If env Then
nbSent = nbSent + 1
End If
End If
j = j + 1
Else
If j = olFolder.Items.Count Then
Exit Do
End If
j = j + 1
End If
Else
If j = olFolder.Items.Count Then
Exit Do
End If
j = j + 1
End If
Loop
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_DossierSent olFolder, dd, df
End Sub
'routine pour parcourir les sous dossiers du dossier Sent Items
Sub Sous_DossierSent(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim olFldr As Outlook.Folder
Dim sourceFolder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
j = 1
For Each Folder In olFolder.Folders
If Not Folder Is Nothing Then
'appel à la macro dossier
DossierSent Folder
Else
Exit Sub
End If
Next Folder
End Sub
'Date Debut Cellule G5 Onglet MAIN
'Date Debut Cellule G7 Onglet MAIN
'Date FILTRE Cellule B2 Onglet FILTRE
Sub main()
Call ini_sub
i = 2
dd = ThisWorkbook.Worksheets("FILTRE").Range("B1").Value
df = ThisWorkbook.Worksheets("FILTRE").Range("B2").Value
dateFiltre = ThisWorkbook.Sheets("FILTRE").Range("B3").Value
nbSent = 0
nbNoCat = 0
nbRecu = 0
nbNoCatOld = 0
Set OlApp = CreateObject("Outlook.Application")
Set myNamespace = OlApp.GetNamespace("MAPI")
'MailBoxName = "Mailbox - MAACHE Amira (EXT) OperCorTpl"
MailBoxName = "Mailbox - Par-Coos-Edm-Dma-Fpv-Low"
nbLines = ThisWorkbook.Sheets("MAIN").Range("A" & Rows.Count).End(xlUp).Row
nbColumns = ThisWorkbook.Worksheets("MAIN").Rows(1).Find(What:="*", After:=ThisWorkbook.Worksheets("MAIN").Range("A1"), SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
col = LettreColonne(nbColumns)
If nbLines > 1 Then
ThisWorkbook.Sheets("MAIN").Range("A2" & ":" & col & nbLines).Clear
End If
Set olFolder = myNamespace.Folders(MailBoxName)
Dim dos As Outlook.Folder
For Each dos In olFolder.Folders
'nbRecu dans tous les dossiers sauf Sent Items
If dos.Name = "Inbox" Or dos.Name = "Configuration" Or dos.Name = "Deleted Items" Or dos.Name = "Folders" Or dos.Name = "Sent Items" Then
If dos.Name = "Inbox" Then
inbox = True
Else
inbox = False
End If
If dos.Name = "Sent Items" Then
env = True
Else
env = False
End If
'parcours du dossier inbox et calcul de nbNoCat
dossier dos
End If
Next dos
jour = Day(minDate)
mois = Month(minDate)
annee = Year(minDate)
ThisWorkbook.Sheets("MAIN").Range("D:D").WrapText = True
ThisWorkbook.Sheets("FILTRE").Range("B8").Value = nbUnRead
ThisWorkbook.Sheets("FILTRE").Range("B7").Value = Format(minDate, "dd/mm/yyyy") 'jour & "/" & mois & "/" & annee
ThisWorkbook.Sheets("FILTRE").Range("B6").Value = nbNoCat
ThisWorkbook.Sheets("FILTRE").Range("B5").Value = nbSent
ThisWorkbook.Sheets("FILTRE").Range("B4").Value = nbRecu
Set olFolder = myNamespace.Folders(MailBoxName)
For Each dos In olFolder.Folders
'nbRecu dans tous les dossiers sauf Sent Items
If dos.Name = "Inbox" Or dos.Name = "Configuration" Or dos.Name = "Deleted Items" Or dos.Name = "Folders" Or dos.Name = "Sent Items" Then
If dos.Name = "Inbox" Then
inbox = True
Else
inbox = False
End If
If dos.Name = "Sent Items" Then
env = True
Else
env = False
End If
'parcours du dossier inbox et calcul de nbNoCat
dossierOld dos
End If
Next dos
ThisWorkbook.Sheets("FILTRE").Range("B9").Value = nbNoCatOld
Call fin_sub
End Sub
Sub dossierOld(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim NumeroJour As Integer
Dim nomDos As String
Dim isMinDate As Boolean
'And dateR = Format(minDate, "dd/mm/yyyy")
j = 1
If olFolder.Items.Count > 0 Then
Do While True
If TypeOf olFolder.Items(j) Is MailItem Then
Set msg = olFolder.Items(j)
dateR = msg.ReceivedTime
NumeroJour = Weekday(d, vbMonday)
isMinDate = (Format(dateR, "dd/mm/yyyy") = Format(minDate, "dd/mm/yyyy"))
d = Format(dateR, "dd/mm/yyyy")
If isMinDate Then
If olFolder.Name Like "Inbox" And msg.Categories Like "" Then
'compter le nbr de msg sans category recus a la date dateFiltre
nbNoCatOld = nbNoCatOld + 1
End If
i = i + 1
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
Else
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
End If
Else
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
End If
Loop
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_DossierOld olFolder, dd, df
End Sub
Sub Sous_DossierOld(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim j As Long
j = 1
For Each Folder In olFolder.Folders
If Not Folder Is Nothing Then
'appel à la macro dossier
dossierOld Folder
Else
Exit Sub
End If
Next Folder
End Sub
My program works fine. It just takes a lot of time when running.
Could anyone give me any advice on how to simplify it so that it can be quicker?
Thank you in advance.
' Ignore the comments, it's in french:)
Option Explicit
Public dd As Date, df As Date
Public dateFiltre As Date
Dim i As Long
Dim MailBoxName As String
Dim OlApp As Object
Dim olFolder As Outlook.Folder
Dim myNamespace As Outlook.Namespace
Dim cellDate As Range
Dim cellStatus As Range
Dim cellObject As Range
Dim cellDossier As Range
Dim cellCategory As Range
Dim cellCC As Range
Dim cellHour As Range
Dim cellExp As Range
Dim cellRecept As Range
Dim cellReadNotRead As Range
Dim cc As Long
Dim ch As Long
Dim ce As Long
Dim cr As Long
Dim crnr As Long
Dim cd As Long
Dim cs As Long
Dim co As Long
Dim ccat As Long
Dim cdir As Long
Dim nbLines As Long
Dim nbColumns As Long
Dim col As String
Dim nbRecu As Long
Dim nbSent As Long
Dim nbNoCat As Long
Dim nbNoCatOld As Long
Dim nbUnRead As Long
Dim inbox As Boolean
Dim env As Boolean
Dim del As Boolean
Dim minDate As String
Dim jour As String
Dim mois As String
Dim annee As String
'deux macros pour accelerer l execution de la macro principale:ini_sub et fin_sub
Public Sub ini_sub()
Application.ScreenUpdating = False 'rafraichissement ecran (pour ne pas voir défiler les macros)
Application.Calculation = xlCalculationManual ' supprime calcul auto EXCEL pour gagner du temps. A remettre dans fin_sub
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
End Sub
Public Sub fin_sub()
Application.ScreenUpdating = True 'rafrfraichissement ecran
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
Function LettreColonne(c As Long) As String
Dim reste As Long
Dim quotient As Long
quotient = Int(c / 26)
reste = c Mod 26
If quotient = 0 And reste = 0 Then
Exit Function
End If
If quotient = 0 Then
LettreColonne = Chr(64 + reste)
Else
If reste = 0 Then
quotient = quotient - 1
If quotient = 0 Then
LettreColonne = Chr(64 + 26)
Else
LettreColonne = Chr(64 + quotient) & Chr(64 + 26)
End If
Else
LettreColonne = Chr(64 + quotient) & Chr(64 + reste)
End If
End If
End Function
Sub Sous_Dossier(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim olFldr As Outlook.Folder
Dim sourceFolder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
j = 1
For Each Folder In olFolder.Folders
If Not Folder Is Nothing Then
'appel à la macro dossier
dossier Folder
Else
Exit Sub
End If
Next Folder
End Sub
Sub dossier(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim h As Date
Dim NumeroJour As Integer
Dim nomDos As String
Dim s As Boolean
'''''''''''''''''''
Dim cellCC As Range
Dim cellHour As Range
Dim cellExp As Range
Dim cellRecept As Range
Dim cellReadNotRead As Range
Dim cc As Long
Dim ch As Long
Dim ce As Long
Dim cr As Long
Dim crnr As Long
'''''''''''''''''''''''''''
j = 1
Set cellCC = ThisWorkbook.Worksheets("MAIN").Cells.Find("CC", lookat:=xlWhole)
cc = cellCC.Column
Set cellHour = ThisWorkbook.Worksheets("MAIN").Cells.Find("HOUR", lookat:=xlWhole)
ch = cellHour.Column
Set cellExp = ThisWorkbook.Worksheets("MAIN").Cells.Find("SENDER", lookat:=xlWhole)
ce = cellExp.Column
Set cellRecept = ThisWorkbook.Worksheets("MAIN").Cells.Find("RECEIVER", lookat:=xlWhole)
cr = cellRecept.Column
Set cellReadNotRead = ThisWorkbook.Worksheets("MAIN").Cells.Find("READ\NOTREAD", lookat:=xlWhole)
crnr = cellReadNotRead.Column
Set cellDate = ThisWorkbook.Worksheets("MAIN").Cells.Find("DATE", lookat:=xlWhole)
cd = cellDate.Column
Set cellDossier = ThisWorkbook.Worksheets("MAIN").Cells.Find("DOSSIER", lookat:=xlWhole)
cdir = cellDossier.Column
Set cellStatus = ThisWorkbook.Worksheets("MAIN").Cells.Find("STATUS", lookat:=xlWhole)
cs = cellStatus.Column
Set cellObject = ThisWorkbook.Worksheets("MAIN").Cells.Find("SUBJECT", lookat:=xlWhole)
co = cellObject.Column
Set cellCategory = ThisWorkbook.Worksheets("MAIN").Cells.Find("CATEGORY", lookat:=xlWhole)
ccat = cellCategory.Column
If olFolder.Items.Count > 0 Then
Do While True
If TypeOf olFolder.Items(j) Is MailItem Then
Set msg = olFolder.Items(j)
dateR = msg.ReceivedTime
d = Format(dateR, "dd/mm/yyyy")
h = Format(dateR, "hh:mm")
NumeroJour = Weekday(d, vbMonday)
'filtrer les mails ne pas afficher ceux reçus samedi ou dimanche
If d > dd And d < df And NumeroJour <> 6 And NumeroJour <> 7 Then
ThisWorkbook.Worksheets("MAIN").Cells(i, cd) = d
s = msg.Sent
ThisWorkbook.Sheets("MAIN").Cells(i, cdir).Value = msg.Parent.Name
ThisWorkbook.Sheets("MAIN").Cells(i, co).Value = msg.Subject
ThisWorkbook.Sheets("MAIN").Cells(i, ccat).Value = msg.Categories
ThisWorkbook.Sheets("MAIN").Cells(i, cc).Value = msg.cc
ThisWorkbook.Sheets("MAIN").Cells(i, ce).Value = msg.SenderName
ThisWorkbook.Sheets("MAIN").Cells(i, cr).Value = msg.ReceivedByName
ThisWorkbook.Sheets("MAIN").Cells(i, ch).Value = h
If msg.unRead = True Then
ThisWorkbook.Sheets("MAIN").Cells(i, crnr).Value = "Not Read"
nbUnRead = nbUnRead + 1
Else
ThisWorkbook.Sheets("MAIN").Cells(i, crnr).Value = "Read"
End If
If olFolder.Name = "Sent Items" Then
If s = True And d = dateFiltre Then
ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Sent"
nbSent = nbSent + 1
Else
ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Brouillon"
End If
Else
ThisWorkbook.Sheets("MAIN").Cells(i, cs).Value = "Received"
If d = dateFiltre Then
nbRecu = nbRecu + 1
End If
If olFolder.Name Like "Inbox" And msg.Categories Like "" Then
'compter le nbr de msg sans category recus a la date dateFiltre
nbNoCat = nbNoCat + 1
If nbNoCat = 1 Then
minDate = dateR
ElseIf nbNoCat > 0 Then
If dateR < minDate Then
minDate = dateR
End If
End If
End If
End If
i = i + 1
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
Else
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
End If
Else
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
End If
Loop
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_Dossier olFolder, dd, df
End Sub
'routine pour calculer le nombre de mails dans le dossier Sent Items
Sub DossierSent(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim nomDos As String
Dim s As Boolean
j = 1
If olFolder.Items.Count > 0 Then
Do While True
If TypeOf olFolder.Items(j) Is MailItem Then
Set msg = olFolder.Items(j)
dateR = msg.ReceivedTime
d = Format(dateR, "dd/mm/yyyy")
'filtrer les mails, compter ceux envoyes a la date d
If d = dateFiltre Then
If j = olFolder.Items.Count Then
If env Then
nbSent = nbSent + 1
End If
Exit Do
Else
If env Then
nbSent = nbSent + 1
End If
End If
j = j + 1
Else
If j = olFolder.Items.Count Then
Exit Do
End If
j = j + 1
End If
Else
If j = olFolder.Items.Count Then
Exit Do
End If
j = j + 1
End If
Loop
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_DossierSent olFolder, dd, df
End Sub
'routine pour parcourir les sous dossiers du dossier Sent Items
Sub Sous_DossierSent(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim olFldr As Outlook.Folder
Dim sourceFolder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim it As Outlook.Items
Dim j As Long
Dim dateR As Date
Dim d As Date
j = 1
For Each Folder In olFolder.Folders
If Not Folder Is Nothing Then
'appel à la macro dossier
DossierSent Folder
Else
Exit Sub
End If
Next Folder
End Sub
'Date Debut Cellule G5 Onglet MAIN
'Date Debut Cellule G7 Onglet MAIN
'Date FILTRE Cellule B2 Onglet FILTRE
Sub main()
Call ini_sub
i = 2
dd = ThisWorkbook.Worksheets("FILTRE").Range("B1").Value
df = ThisWorkbook.Worksheets("FILTRE").Range("B2").Value
dateFiltre = ThisWorkbook.Sheets("FILTRE").Range("B3").Value
nbSent = 0
nbNoCat = 0
nbRecu = 0
nbNoCatOld = 0
Set OlApp = CreateObject("Outlook.Application")
Set myNamespace = OlApp.GetNamespace("MAPI")
'MailBoxName = "Mailbox - MAACHE Amira (EXT) OperCorTpl"
MailBoxName = "Mailbox - Par-Coos-Edm-Dma-Fpv-Low"
nbLines = ThisWorkbook.Sheets("MAIN").Range("A" & Rows.Count).End(xlUp).Row
nbColumns = ThisWorkbook.Worksheets("MAIN").Rows(1).Find(What:="*", After:=ThisWorkbook.Worksheets("MAIN").Range("A1"), SearchDirection:=xlPrevious, SearchOrder:=xlByColumns).Column
col = LettreColonne(nbColumns)
If nbLines > 1 Then
ThisWorkbook.Sheets("MAIN").Range("A2" & ":" & col & nbLines).Clear
End If
Set olFolder = myNamespace.Folders(MailBoxName)
Dim dos As Outlook.Folder
For Each dos In olFolder.Folders
'nbRecu dans tous les dossiers sauf Sent Items
If dos.Name = "Inbox" Or dos.Name = "Configuration" Or dos.Name = "Deleted Items" Or dos.Name = "Folders" Or dos.Name = "Sent Items" Then
If dos.Name = "Inbox" Then
inbox = True
Else
inbox = False
End If
If dos.Name = "Sent Items" Then
env = True
Else
env = False
End If
'parcours du dossier inbox et calcul de nbNoCat
dossier dos
End If
Next dos
jour = Day(minDate)
mois = Month(minDate)
annee = Year(minDate)
ThisWorkbook.Sheets("MAIN").Range("D:D").WrapText = True
ThisWorkbook.Sheets("FILTRE").Range("B8").Value = nbUnRead
ThisWorkbook.Sheets("FILTRE").Range("B7").Value = Format(minDate, "dd/mm/yyyy") 'jour & "/" & mois & "/" & annee
ThisWorkbook.Sheets("FILTRE").Range("B6").Value = nbNoCat
ThisWorkbook.Sheets("FILTRE").Range("B5").Value = nbSent
ThisWorkbook.Sheets("FILTRE").Range("B4").Value = nbRecu
Set olFolder = myNamespace.Folders(MailBoxName)
For Each dos In olFolder.Folders
'nbRecu dans tous les dossiers sauf Sent Items
If dos.Name = "Inbox" Or dos.Name = "Configuration" Or dos.Name = "Deleted Items" Or dos.Name = "Folders" Or dos.Name = "Sent Items" Then
If dos.Name = "Inbox" Then
inbox = True
Else
inbox = False
End If
If dos.Name = "Sent Items" Then
env = True
Else
env = False
End If
'parcours du dossier inbox et calcul de nbNoCat
dossierOld dos
End If
Next dos
ThisWorkbook.Sheets("FILTRE").Range("B9").Value = nbNoCatOld
Call fin_sub
End Sub
Sub dossierOld(olFolder As Outlook.Folder)
Dim Folder As Outlook.Folder
Dim msg As Outlook.MailItem
Dim j As Long
Dim dateR As Date
Dim d As Date
Dim NumeroJour As Integer
Dim nomDos As String
Dim isMinDate As Boolean
'And dateR = Format(minDate, "dd/mm/yyyy")
j = 1
If olFolder.Items.Count > 0 Then
Do While True
If TypeOf olFolder.Items(j) Is MailItem Then
Set msg = olFolder.Items(j)
dateR = msg.ReceivedTime
NumeroJour = Weekday(d, vbMonday)
isMinDate = (Format(dateR, "dd/mm/yyyy") = Format(minDate, "dd/mm/yyyy"))
d = Format(dateR, "dd/mm/yyyy")
If isMinDate Then
If olFolder.Name Like "Inbox" And msg.Categories Like "" Then
'compter le nbr de msg sans category recus a la date dateFiltre
nbNoCatOld = nbNoCatOld + 1
End If
i = i + 1
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
Else
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
End If
Else
j = j + 1
If j > olFolder.Items.Count Then
Exit Do
End If
End If
Loop
End If
nomDos = olFolder.Name
'appel à la macro ss dossier
Sous_DossierOld olFolder, dd, df
End Sub
Sub Sous_DossierOld(olFolder As Outlook.Folder, dd As Date, df As Date)
Dim Folder As Outlook.Folder
Dim j As Long
j = 1
For Each Folder In olFolder.Folders
If Not Folder Is Nothing Then
'appel à la macro dossier
dossierOld Folder
Else
Exit Sub
End If
Next Folder
End Sub