PDA

View Full Version : [SOLVED] Process too long for counting received,sent mails etc. with Outlook



FrancisZheng
02-06-2017, 10:08 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

p45cal
02-06-2017, 11:19 AM
I will look at this in more depth tomorrow, however, in haste, below I have:

commented-out what I think is unnecessary/unused,
changed one bit of code (LettreColonne - it may have no effect as it may not be called often),
added one or two comments.

I can't test.
I doubt the changes so far will make any impact on speed.
How long does it actually take?

Next I'll look at the logic/algorithms/using With..End With; for example in sub dossier you have many references to ThisWorkbook.Worksheets("MAIN"). Every time you use this Excel has to resolve it, so using With ThisWorkbook.Worksheets("MAIN") and later End With, then removing all instances of ThisWorkbook.Worksheets("MAIN") within (leaving the dot) may speed it up since Excel only has to resolve it once.

In the same sub you have a whole series of pairs of lines thus:

Set cellCC = ThisWorkbook.Worksheets("MAIN").Cells.Find("CC", lookat:=xlWhole)
cc = cellCC.ColumnThere is no error checking so there may be no need to set up an object variable cellCC (it's not used elsewhere), instead use the single line:

cc = ThisWorkbook.Worksheets("MAIN").Cells.Find("CC", lookat:=xlWhole).column


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

'The following are also Dimmed in dossier and used exclusively there:
'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 'could this one be Dimmed in dossier?
Dim co As Long 'could this one be Dimmed in dossier?
Dim ccat As Long 'could this one be Dimmed in dossier?
Dim cdir As Long 'could this one be Dimmed in dossier?

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
LettreColonne = Split(Cells(1, c).Address, "$")(1)
' 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

FrancisZheng
02-06-2017, 01:26 PM
Hi P45cal,

thank you for answering me so quickly.

I'll look at your modification the first thing tomorrow morning.

Regards,
Francis.

FrancisZheng
02-07-2017, 03:49 AM
Hi P45cal,

I adapted some simplification of the code and kept the integrality of the code for further use. Thanks a lot.

I found a way to save time to great extent. But I don't know how to write the code.

The idea is to keep all the data in the MAIN sheet and add new data to it. During the execution, the code will delete the data of yesterday since it may not be complete(for ex : last time I lanced the program was yesterday noon, so the mails of yesterday's afternoon weren't copied) and then start copying from debut yesterday.

Unfortunately, this is a code from another person, so I don't know to where to modify the code. So if you have any idea, please give me some ideas.

snb
02-07-2017, 04:38 AM
Reduce reading/writing from/to a worksheet to the minimum.
Use arrays to store data temporarily.

p45cal
02-08-2017, 02:33 PM
OK, I think huge improvements can be made; there are unused macros, unused variables, unrequired multiple execution of lots of code, unusual recursion. It's going to be quicker to re-write from scratch than try to 'adjust' your code, so I will have questions as I develop this. Please answer all the questions, and if you don't know the answer to any, say so rather than ignore it.
1. What is the header on sheet MAIN column D?
2. Do you intend ALWAYS to have the table start in column A?
3. Your code is written in such a way that the column headers: CC,HOUR,SENDER,RECEIVER,READ\NOTREAD,DATE,DOSSIER,STATUS,SUBJECT,CATEGORY can each be in any column on the MAIN sheet, even with other column headers or blank columns inbetween. Do you want to keep this facility? (I suppose here I'm asking whether in reality the 10 columns are all next to each other, for example in columns A to J?) The reason I ask is that I want to avoid writing to the sheet one cell at a time (because it takes time), instead I want to write to the sheet in blocks, and I can write the full width of the table in one hit, or column by column. It doesn't make a lot of difference to the time, but it does make a difference to the code.

That's enough for now.

FrancisZheng
02-09-2017, 04:51 AM
Hello P45cal,

I thought it would be better to start from scratch too, so I starteda new thread here :

vbaexpress.com/forum/showthread.php?58526-Retrieve-data(Time-From-subject-category)-from-Outlook-inbox-to-Execl

In the first sheet, there will be counts of sent mails, received mails and mails without category.
In the second sheet, there will be data of all received and sent mails like this :

date hour status folder subject category read/not read cc receiver sender
...

Since there are thousands of mails that need to be retrieved, the best way is to just retrieve the new mails since the last exection of the macro so we don't have to repeat copying old mails and waste time.

To your 3 questions P45cal :
1. folder(for ex : Deleted Items) I listed all the columns î.
2. Yes, the date is column A, then hour...
3. Yes, all the columns are one to another which starts from column A, if there is no information, then a cell is blank.
The first line of the sheet is titile, then the data starts from the secod line.

Thank you so much for willing to take your precious time and help me with the work which is very important to my job.

Regards,
Francis

p45cal
02-09-2017, 08:16 AM
Thank you Francis, that makes things easier.
Now for some more. I'm trying to determine the intention behind various things:
1. The date in B3 of sheet FILTRE?
2. cell B9 of the same sheet (nbNoCatOld)

(Personally, I think there's only a 50/50 chance that the results you get are what you think they are!)

FrancisZheng
02-09-2017, 08:43 AM
Hello P45cal,

For your questions :

1. I think it was for user to put the date of the last exection of the macro. But it's not useful anymore. We kind of hope it can be done automaticaly.

2. The cell isn't used anymore. We can just delete it.

This is indeed a tricky project !

Regards,
Francis

FrancisZheng
02-09-2017, 08:59 AM
Actually I was wrong. For the second question, the cell is for the number of the date of the oldest uncategorized mail(s). For ex : the oldest uncategorized mails were 01/01/2017, and there were 3 uncategorized mails that day. So the cell B9 will show the value 3.

p45cal
02-09-2017, 05:53 PM
The attached has a macro main which you should run after adusting the two dates in cells B1 and B2 of the FILTRE sheet - keep the dates close to each other to start with (one or two days apart) in order to assess speed.
It is not finished!
There are comments on the FILTRE sheet, and a few in the code.
Where I have put 'Not in use' I'll wait for clarification from you as to what you want exactly.

It could be tweaked to add only the latest data but that might get complicated, especially, for example if an email's Status changes (even an old one) but you've already brought it over into Excel. Currently it wipes the sheet as before and repopulates it.

I did ask before, how long does the process typically take using the original code?

FrancisZheng
02-10-2017, 01:50 AM
Hello P45cal,

I just woke up(in France). I read your code and then tried to run the macro "main". But it says "Compile error : Can't find project or Library". It's microsoft 14.0 object library that is missing. I searched on the internet, it seems that using late binding might be the only solution. Do you have an idea on how to fix this?

Sorry I didn't answer before. It took me two hours or more to run the process. In fact, the file is used every monday to wednesday morning at the meeting when we arrive at work. Since we have to turn off everything after work and we don't have two hours before the meeting, we won't have all the data we need during the meeting. So that's the big problem we are having.

Thank you so much.

Regards,
Francis

snb
02-10-2017, 02:50 AM
Wouldn't it be better to hire a consultant at your place ?

FrancisZheng
02-10-2017, 05:06 AM
I hope I could but I can't. I'm still an intern engineer...

p45cal
02-10-2017, 05:17 AM
I read your code and then tried to run the macro "main". But it says "Compile error : Can't find project or Library". It's microsoft 14.0 object library that is missing. I searched on the internet, it seems that using late binding might be the only solution.In the VBE (Visual Basic Editor), Tools|References… Untick the Missing Microsoft Outlook 14.0 Object library, and scroll down until you find another Microsoft Outlook nn.n Object Library, tick it and OK. Try again.
If you just woke up you were at home? It could be that the correct library is present at work.
Yes late binding is possible, but your original code was early binding so it shouldn't be necessary.

FrancisZheng
02-10-2017, 05:43 AM
Hello P45cal,

You are right. I tried and It worked well this time except there's nothing in the category column...

I also got a response from another thread which can add new data since the last execution of the macro to the main sheet. If you could somehow combine this with the program, I think the work is succeeded.

18311

Regards,
Francis

p45cal
02-10-2017, 06:39 AM
I tried and It worked well this timeHow well? How long did it take to do the about the same size of task that took 2 hours before?




except there's nothing in the category column...then it's likely that there is no category assigned to those emails; I've just tested here and categories do appear if they are present.




i also got a response from another thread which can add new data since the last execution of the macro to the main sheet. If you could somehow combine this with the program, I think the work is succeeded.We need to walk before we jump - there are still things to clear up with the logic. You need to address my comments in the last attachment on sheet FILTRE and be certain what dateFiltre was about as I there is more to it then " I think it was for user to put the date of the last exection of the macro. But it's not useful anymore. We kind of hope it can be done automaticaly."

Also remember what I said before:"It could be tweaked to add only the latest data but that might get complicated, especially, for example if an email's Status changes (even an old one) but you've already brought it over into Excel."

FrancisZheng
02-10-2017, 07:31 AM
Hello P45cal,


How well? How long did it take to do the about the same size of task that took 2 hours before?
I only tried with a small simple and it worked well. Since we still have to copy all the data I thought the time might not change too much. I'm running and it hasn't finished yet.


then it's likely that there is no category assigned to those emails; I've just tested here and categories do appear if they are present.

Exactly, I assigned categories and it worked great.


We need to walk before we jump - there are still things to clear up with the logic. You need to address my comments in the last attachment on sheet FILTRE

The date dd and df are included in the result. nbRecu, nbSent, nbNoCat, nbNoCatOldDate, nbUnread, nbNoCatOld are exactly what you think they are, they will eventualy be used. dateFiltre means the date we want all the results in sheet one : nbRecu, nbSent, nbNoCat, nbNoCatOldDate, nbUnread, nbNoCatOld etc(so all these are just results for one day : dateFiltre).

Regards,
Francis

p45cal
02-10-2017, 08:38 AM
Is dateFiltre always going to be within df and dd?

FrancisZheng
02-10-2017, 08:47 AM
Is dateFiltre always going to be within df and dd?

Yes, so that there will be data for this day. dd and df won't be used evetually, but dateFiltre is always used because the data of the sheet 1 depends on its date.

Francis

p45cal
02-10-2017, 09:16 AM
Now you're really throwing me.
"sheet 1"?
MAIN or FILTRE?



dd and df won't be used!?

FrancisZheng
02-10-2017, 09:26 AM
Sorry, I didn't mean to give you this impression.

Sheet 1 is Filtre, on which all the data is based on the day dateFiltre.

The reason I said that dd and df won't be used eventually is that if we succeed in adding new data to the sheet MAIN, then we won't retrieve data based on dd and df. The reason we created dd and df was to avoid time loss caused by retrieving all 20000 lines of data.

Francis

p45cal
02-12-2017, 04:04 PM
Have a go with the attached.
Spent significant time getting around the .Restrict method only working to the nearest minute.
Tested, but not thoroughly.
Notes on FILTRE sheet.

I'd be interested in timings. It took less than 2 minutes to retrieve more than 10k emails here.

FrancisZheng
02-13-2017, 02:15 AM
Hello Pascal,

Thank you so much for your program.

I tested the code step by step, and when the code runs to
ddminus = Application.Floor_Precise(dd, 1 / 24 / 60) there's an error and it jumps to the end.

What might be the problem?

Regards,
Francis

p45cal
02-13-2017, 02:34 AM
What version of Excel are you using?
Try removing
_Precise

FrancisZheng
02-13-2017, 03:07 AM
I'm using Excel2007, Outlook2012.

I removed it and it worked. Now I'm trying to run with the big mailbox.

I have a couple of questions that I would like to learn from you.

1. Everytime Outlook is closed after execution. Is that made for a purpose? Can I let it reamain open if it's open in the first place?

2. To your question,
Maybe there should be a 'Latest date and time on MAIN sheet to dd' ?
I think there might be just two buttons needed. The first one being "Update", which will put the time now to dateFiltre(same as Today to Filtre) and df. It will also put the day of the last time of the exection to dd. The second button is "Fetch mails". The reason there are 2 buttons instead of one is that in case we don't want to use the defalut date settings set by "Update", which I'm inspired from you. Do you think this is possible to be done?

Francis

p45cal
02-13-2017, 03:49 PM
1. Everytime Outlook is closed after execution. Is that made for a purpose? Can I let it reamain open if it's open in the first place?This sort of thing is a minefield; I just left the code you had except for the addition of the .Quit line - I wanted to prevent multiple instances of Outlook running. Outlook behaves differently from the other Office applications in this regard. I've added some code which is meant to leave Outlook open if it was already running, and shut it down if it wasn't. I'm not going to guarantee it's going to work.
See these sites for the kind of problems that might arise:
http://www.rondebruin.nl/win/s1/outlook/openclose.htm
https://www.experts-exchange.com/articles/17466/Properly-open-Outlook-as-an-Application-object-in-VBA.html
http://www.devhut.net/2014/10/31/createobjectoutlook-application-does-not-work-now-what/




2. To your question, I think there might be just two buttons needed. The first one being "Update", which will put the time now to dateFiltre(same as Today to Filtre) and df. It will also put the day of the last time of the exection to dd. I can't do that because of "EITHER you have 2 dates in the top 2 cells OR you have one date in the 3rd cell"



The second button is "Fetch mails". The reason there are 2 buttons instead of one is that in case we don't want to use the defalut date settings set by "Update", which I'm inspired from you. Do you think this is possible to be done? I've added button Update, with what it does described. Be very careful, if you click that button with nothing on the MAIN sheet (before you're asked whether you want to clear it), the dd date will be 1 Jan 1900! (all the emails in Outlook!)

You can delete any other button you don't want.

FrancisZheng
02-14-2017, 02:16 AM
Thank you P45cal. It's very kind of you.

I'll look into your code once I arrive at work.

Francis

p45cal
02-15-2017, 03:29 AM
I'll look into your code once I arrive at work.…and?

FrancisZheng
02-15-2017, 09:14 AM
…and?

Sorry P45cal, I was out on a business trip with my superior. So I don't have the office pack to test the program.

I will get back to you once I return.

Have a nice day !

Regards,
Francis

FrancisZheng
02-17-2017, 05:04 AM
Hello P45cal,

I returned to work this morning. I tested the program and looked at the code. Like always, there's no bug.

The update process works very well. In this way, it takes much less time to finish the process.

I understand your purpose on shutting down Outlook now. Since I only had one Outlook open when I tested, I'm not totally sure the new function works. But it wasn't shut down this time, which is exactly what I wanted.

Unfortunately, my chef asked me to change the format for the final version of work in adding a bit of functions. So I made some modifications and added textboxes for comments. Most of the functions are already realised. I think we wouldn't need dd and df anymore. Only target date will do the job.

I already tried to do it myself this morning. But I ran into many difficulties. For instance, in order to sort the data, I need to use both date and hour. Then I was stuck.

Could you see if it's doable to accomplish this final version of the file? I promise this is the final one. After it's done, the task will be completely finished.

Thank you in advance.

Regards,
Francis

18406

p45cal
02-17-2017, 06:02 AM
I'm sorry, this is too much.
I've already spent far longer on this than I would normally have on a for-free basis, especially as this is clearly for commercial purposes.
As far as sorting is concerned, you should be able to sort, manually, on 2 columns, date and time? Record a macro of you doing it.
Curiously, I will be driving to France in 2 weeks time for about 10 days, skiing!

FrancisZheng
02-17-2017, 06:59 AM
Hi P45cal,

Actually it's not for commercial use. I use this for work though. Our team has a mailbox that combines all our mails. Since there are too many mails in it, the chef of our team thought it would be more convenient to do the operations in Excel rather than in Outlook, for example count number of mails and search key words. That's where my work came in place since I'm a intern. Unfortunately, I didn't have much experience in VBA programming. That's why you helped me do almost all the job for me. You have helped me so much with my work. I can't thank you more for all the trouble.

I was wondering if I could pay you to help me with the last step of the program. Because this is very first mission my boss gave me, even though it's completely not a task for my specialty, there's no way I can fail it. I tried to copy the code to do the same counts for all the dates as for the one target date, but there were too many errors in the code. And I don't know which one to begin with.

Have fun skiing in France.

Regards,
Francis

p45cal
02-17-2017, 07:20 AM
Actually it's not for commercial use. I use this for work though. Our team has a mailbox that combines all our mails. Since there are too many mails in it, the chef of our team thought it would be more convenient…Of course it's commercial.





I was wondering if I could pay you to help me with the last step of the program.As an intern, I'd doubt that you would want to afford it. A company such as the Société Générale could though.





I tried to copy the code to do the same counts for all the dates as for the one target date, but there were too many errors in the code. And I don't know which one to begin with.Why don't you use the existing code to search for various things (it's flexible enough, after all), and copy/paste the results to another sheet?

FrancisZheng
02-17-2017, 08:37 AM
Hi P45cal,

Sorry, I didn't know the definition of "commercial", I thought it meant for sale as a product.

I will try to fix the bugs caused by bad copying because I don't count my company to pay for this:)

Thanks you!

Francis

FrancisZheng
02-23-2017, 02:41 AM
Hello P45cal,

I succeeded in finishing the final version.

Thank you for the help you've given me. I couldn't have succeeded without your code.

Regards,
Francis