Process trop long pour parcourir mailbox dans Outlook

Bonjour à tous,

J'ai créé un programme pour parcourir tous les mails dans mon mailbox et compter les mails reçus, envoyés etc. Il fonctionne bien.

Le problème est que chaque fois il prend trop de temps.

Je voudrais donc vous demander de m'aider voir s'il est possible d'être simplifié.

Merci par avance.

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

Bonjour

FrancisZheng a écrit :

Bonjour à tous,

J'ai créé un programme pour parcourir tous les mails dans mon mailbox et compter les mails reçus, envoyés etc. Il fonctionne bien.

Le problème est que chaque fois il prend trop de temps.

Si je lis bien le code, il ne fait pas que compter, il répertorie et inscrit les mails dans différentes feuilles d'un classeur

Quel intérêt !!????

Bonne chance

Bonjour BrunoM45,

Merci de m'avoir répondu.

En effet, il extrait aussi des informations dans les deux autres classeurs. C'est des informations nécessaires pour l'utilisateur du programme. Donc je ne pourrais pas supprimer cette partie.

Vous avez des idées sur la simplification du process?

Bonjour FrancisZheng, (BrunoM45)

J'ai regardé ton code en vitesse et je te propose une solution (rapide) qui devrait améliorer un peu ces performances - en terme de rapidité...

Les modifications et commentaires sont intégrés dans ton code...

Je pense qu'il doit être possible d'optimiser aussi tes boucles, mais sans fichier c'est difficile à tester...

Autre conseil (mais il ne s'agit que d'un avis perso, de ma propre manière de programmer) évite les Exit en général et les ElseIf

Il y a souvent une manière de tourner les conditions dans l'autre sens !

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

'-------------------------------
' a essayer !!!
' 1) ajouter cette déclaration
' 2) et cette affectation
Dim wsActif As Object

    Set wsActif = workshetts("MAIN")
'
'-------------------------------
' 3) indenter correctement le code ! ça ne va l'accélérer mais c'est plus facile à lire !!!
'-------------------------------
'
' 4) ajouter une ligne
'       With wsAcit     au début de tes tests => je l'ai fait...
' 5) ajouter une ligne
'       End With        à la fin de test tests => je l'ai fait aussi !!!
' 6) remplacer tous les
'       ThisWorkbook.Sheets("MAIN") par rien !
'       càd que les lignes du style
'           ThisWorkbook.Sheets("MAIN").Cells(i, cdir).Value = msg.Parent.Name
'       deviennent
'           .Cells(i, cdir).Value = msg.Parent.Name
'       j'ai fait la première pour exemple après la ligne
'           If d > dd And d < df And NumeroJour <> 6 And NumeroJour <> 7 Then
'
'-------------------------------
' ce procédé devrait rendre le code plus rapide par ce que tu ne vas plus chercher
' ThisWorkbook.Sheets("MAIN") à chaque fois
' mais tu y fais référence grâce aux With/End With !!
'-------------------------------

'''''''''''''''''''''''''''
    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

    With wsActif

        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
                        .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

    End With
    nomDos = olFolder.Name
    'appel à la macro ss dossier
    Sous_Dossier olFolder, dd, df

End Sub

Bonjour BrunoM45,

Je vous remercie de votre temps et effort pour m'aider. J'ai testé votre programme. C'est de bonnes idées que vous avez proposé. Normalement il fonctionne bien.

J'ai une idée pour largement réduire le temps du travail. L'idée est de garder les données dans la feuille MAIN, et d'ajouter des nouvelles données dessus. Lors de chaque exécution, il suffit de supprimer les données de la veille car ceci peut être imcomplètes(par ex : la dernière exécution était hier midi, donc les mails d'hier apm ne sont pas recopiés) et d'importer à partir du début hier.

Est-ce que vous auriez des idée comment modifier le code?

Voici mon nouveau programme. Je pense qu'il y a des erreurs sur MesMails, MesMailsInitial et olFolder.Items. Mais je ne sais pas où il est.

 

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

Dim LeFiltre As String

Dim MesMails, MesMailsInitial As Outlook.Items

'Dim MonMot As String

' du dossier actif

With ActiveExplorer.CurrentFolder

    ' on écrit le filtre : les éléments reçus après le 01/01/2017 00h00

    LeFiltre = "[Receivedtime] > '" & Format((df), "dd/mm/yyyy hh:mm") & "'"

    ' parmi les mails du dossier, j'applique la restriction

    'Set MesMailsInitial = .Items.Restrict(LeFiltre)

    'MesMailsInitial est donc le lot de mails > DateFin

    ' maintenant, on va sous-filtrer cette collection pour ne sortir que les mails dont l'objet contient un certain texte

    'MonMot = "Texte dans l'objet"

    'LeFiltre = "@SQL=""http://schemas.microsoft.com/mapi/proptag/0x0037001f"" like '%" & MonMot & "%'"

    Set MesMails = MesMailsInitial.Restrict(LeFiltre)

    ' MesMails est la sous-collection appartenant à MesMailsInitial, où chaque item possède dans l'objet la chaine de caractère cherchée

End With

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"

MailBoxName = "Mailbox - ZHENG Jianwei OperClmRrdSno"

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