Discussion :

[CAPRI_456]

Bonsoir le Forum,

Je souhaite évoquer avec vous un problème.

J'ai réussi à introduire une restriction sur une boucle dans l'inbox qui doit prendre en considération uniquement les MAILS qui arrivent (ReceivedTime) entre 06.00 h du jours en cours et 06.00 h du matin du jour suivant.

J'ai déjà un code qui fonctionne lorsque l'on définit exactement la date et l'heure dans le code : voici

'Declare VARIABLES pour " JOUR D'ANALYSE..."
Dim JourneeAnalyse As String
Dim today
Dim Jour As String, Mois As String, Annee As String
Annee = Year(Now)
Mois = Month(Now)
Jour = Day(Now)

today = Jour & "-" & Mois & "-" & Annee
JourneeAnalyse = Format(DateAdd("h", 6, today), "dd-mm-yy") 'renvoie today +6heures(du jour suivant)
JourneeAnalyseDebut = Format(DateAdd("h", 6, today), "dd/mm/yyyy hh:mm")
JourneeAnalyseFin = Format(DateAdd("h", 30, today), "dd/mm/yyyy hh:mm")
'________________________________________________________________________________________________________

'recupere l'heure et les minutes de reception de l'email

Set colItems = FldDossier.Items
'avec une restriction sur la période de récupération
Set colFilteredItems = colItems.Restrict("[ReceivedTime] > 'JourneeAnalyseDebut ' AND [ReceivedTime] < 'JourneeAnalyseFin '")
'ci-dessous code qui fonctionne :

Set colFilteredItems = colItems.Restrict("[ReceivedTime] > '18/05/2009 01:00 AND [ReceivedTime] < '18/05/2009 12:00 '")

'note : http://blogs.technet.com/heyscriptingguy/archive _
'/2007/10/05/hey-scripting-guy-how-can-i-save-the-attachments-for-all-my-new-office-outlook-messages.aspx
'_________________________________________________________________________________________________________
'Boucle afin de parcourir l'ensemble des E-mails présents dans le dossier Boîte de réception

'For Each MonMail In FldDossier.Items
For Each MonMail In colFilteredItems

sav_mail_as_msg MonMail
End If
Next MonMail

Voilà mon problème est d'adapter la ligne en rouge pour qu'elle puisse fonctionner tout comme la ligne en bleu....

ainsi je ne dois pas changer chaque jour

Merci pour votre aide...

CAPRI_456

[CAPRI_456]

bonsoir le Forum,

Après avoir pioché un peu partout, j'ai résolu mon problème de restriction.
EN voici les étapes :

Au cas ou certaines idées pourraient être utiles....
Bien à vous

' OUTLOOK 2003
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++ A0 --- PARCOURIR INBOX à la recherche de MAILS
'++++ A1 ---- restriction : date/heure du mail
'++++ A2 ---- restriction : expéditeur du mail
'++++ A3 --- ARCHIVAGE DES MAILS après exécurtion des restrictions
'++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'http://www.developpez.net/forums/d659803/logiciels/microsoft-office/outlook/
' vba-outlook/sauvegarder-selection-demail-specification-repertoire/
Sub ParcourirInbox()
'adapté au départ du code d'olivier LEBEAU(développez.net)
' ************************ Déclaration des Objets et variables
Dim MonApply As Outlook.Application
Dim MonMail As Outlook.MailItem
Dim MonNSpace As Outlook.NameSpace
Dim FldDossier As Outlook.MAPIFolder
' ************************* Instance des Objets
Set MonApply = Outlook.Application 'Application Outlook
Set MonNSpace = MonApply.GetNamespace("MAPI") 'Banque MAPI
Set FldDossier = MonNSpace.GetDefaultFolder(olFolderInbox) 'boîte de réception

' ************************* Declare VARIABLES pour " JOUR D'ANALYSE..." Dim JourneeAnalyse As String
Dim today
Dim Jour As String, Mois As String, Annee As String
Annee = Year(Now)
Mois = Month(Now)
Jour = Day(Now)
today = Jour & "-" & Mois & "-" & Annee

' ************************ Définitions pour restrictions "période de réception"
JourneeAnalyse = Format(DateAdd("h", 6, today), "dd-mm-yy") 'renvoie today +6heures(du jour suivant)
JourneeDebut = "11/05/2009 08:00:00"
JourneeFin = "12/05/2009 02:00:00"
JourneeAnalyseDebut = Format(DateAdd("h", 6, today), "dd/mm/yyyy hh:mm:ss")
JourneeAnalyseFin = Format(DateAdd("h", 30, today), "dd/mm/yyyy hh:mm:ss")



'_____________________________________________________________________________________________________
'++++++ A0 ---- PARCOURIR INBOX à la recherche de MAILS
'______________________________________________________________________________________________________


For Each MonMail In FldDossier.Items

' ************************* définit date/heure/nom des mails d'origine présents inbox
NomMailOrigine = Format(MonMail.ReceivedTime, "dd-mm-yyyy hh-mm") & "_" & MonMail.Subject

'''========= définit le répertoire de sauvegarde sur le serveur "U"
Dim Chemin8 As String
Chemin8 = "D:\Mails-reçus-T-" & JourneeAnalyse
If Dir(Chemin8, vbDirectory + vbHidden) = "" Then MkDir Chemin8
'...si le DOSSIER n'existe pas,le créer
ChDIr Chemin8

'______________________________________________________________________________________________________
'+++++++ A2 ----- RESTRICTION ::::::::::::::: fonction de l'expéditeur du MAIL
'______________________________________________________________________________________________________[/COLOR]

If MonMail.SenderEmailAddress = "capri@xxxxxxxxx.be" Then

'======'Ici on supprime les caractères non autorisé dans les noms de fichiers

PathNomMailOrigine = Chemin8 & "reçu_" & Left _
(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), _
vbTab, ""), Chr(7), ""), 160) & ".Msg"

'===== Ici évite d'écraser les messages identiques , donc ajouté une incrémentation automatique
'===== PAS UTILE pour nos besoins
''' n = 1
''' MemPath = PathNomMailOrigine
''' While Dir(PathNomMailOrigine) <> ""
''' MsgBox "Le fichier " & vbCr & PathNomMailOrigine & vbCr & "existe déjà", vbInformation
''' PathNomMailOrigine = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
''' n = n + 1

''' Wend
'______________________________________________________________________________________________________
'A1 ========= RESTRICTION ::::::::::::::: fonction de la PERIODE DE RECEPTION + PERIODE D'ANALYSE
'______________________________________________________________________________________________________
If Format(MonMail.ReceivedTime, "dd/mm/yyyy hh:mm") > Format(JourneeDebut, "dd/mm/yyyy hh:mm") Then
If Format(MonMail.ReceivedTime, "dd/mm/yyyy hh:mm") < Format(JourneeFin, "dd/mm/yyyy hh:mm") Then

'______________________________________________________________________________________________________
'A3 ========= SAUVEGARDE DES MAILS SELON PERIODE D'ANALYSE
'______________________________________________________________________________________________________

'===== ENREGISTRE chaque mail trouve dans un répertoire prédéfini : serveur D:\mails du......

MonMail.SaveAs Chemin8 & "\" & NomMailOrigine & ".MSG", olMsg
End If ' fin de la restriction sur l'expéditeur
End If ' fin de la restriction sur période "début d'analyse"
End If ' fin de la restriction sur période "fin d'analyse"
'_____________________________________________________________________________________________________
'++++++ A0 ---- PARCOURIR INBOX à la recherche de MAILS - suite de la boucle
'______________________________________________________________________________________________________

Next MonMail ' recherche du mail suivant


'Vide des instances
Set MonApply = Nothing
Set MonNSpace = Nothing
Set FldDossier = Nothing
Set MonMail = Nothing

End Sub

Bonne soirée
CAPRI_456

[CAPRI_456]

BonJOUR le Forum, je cherche toujours une solution,

Malgré mes nouvelles tentatives , je parviens à archiver dans les répertoires si les mails reçus sont
1er cas : entre 06:00 h et 24:00 h
Par contre je n'arrive pas s'ils sont
2ème cas : entre 00:00 h et 06:00 h

j'ai abandonné l'utilisation de la restrictions sur les iTEMS

Mes répertoires se créent pour la journee en cours ( JA) et pour le jour d'avant (JAPREC) et je parviens à y classer les mails reçus dans le 1er cas mais pas dans le 2ème cas


-j'ai crée deux chemins pour le classement dans les répertoires
- j'ai crée un rupture pour ma journée :
--- JAD à JARUPT doivent reçevoir les mails de 00 à 06 h
--- JARUPT à JAF doivent reçevoir les maisl de 06 à 24 h


est-ce dû à un problème de formattage des dates de réception des mails
"ReceivedTime ??

Merci pour votre aide

' OUTLOOK 2003
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++ A0 --- PARCOURIR INBOX à la recherche de MAILS
'++++ A1 ---- restriction : date/heure du mail
'++++ A2 ---- restriction : expéditeur du mail
'++++ A3 --- ARCHIVAGE DES MAILS après exécurtion des restrictions
'++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Sub ParcourirInbox()

' ************************ Déclaration des Objets et variables
Dim MonApply As Outlook.Application
Dim MonMail As Outlook.MailItem
Dim MonNSpace As Outlook.NameSpace
Dim FldDossier As Outlook.MAPIFolder
' ************************* Instance des Objets
Set MonApply = Outlook.Application 'Application Outlook
Set MonNSpace = MonApply.GetNamespace("MAPI") 'Banque MAPI
Set FldDossier = MonNSpace.GetDefaultFolder(olFolderInbox) 'boîte de réception

' ************************* Declare VARIABLES pour " JOUR D'ANALYSE..."
Dim JA, JAD, JAF, JAPREC, JARUPT As String
Dim today
Dim Jour As String, Mois As String, Annee As String
Annee = Year(Now)
Mois = Month(Now)
Jour = Day(Now)
today = Format(Jour & "-" & Mois & "-" & Annee, "dd-mm-yyyy hh:mm")

' ************************ Définitions pour restrictions "période de réception"
JA = Format(DateAdd("h", 0, today), "dd-mm-yyyy") 'JA = JourneeAnalyse
JAPREC = Format(DateAdd("h", -1, today), "dd-mm-yyyy") 'JAPREC = JourneeAnalyse moins 1h me donne le jour précédent
' JAD = Format(DateAdd("h", 0, today), "dd-mm-yyyy hh:mm:ss") 'JourneeAnalyseDebut
' JARUPT = Format(DateAdd("h", 6, today), "dd-mm-yyyy hh:mm:ss") 'JourneeAnalyseRupture
' JAF = Format(DateAdd("h", 24, today), "dd-mm-yyyy hh:mm:ss") 'JourneeAnalyseFin

'Ici j 'ai introduit quelques données pour le test

JAD = "20-05-2009 00:00"
JARUPT = "20-05-2009 06:00"
JAF = "20-05-2009 24:00"
'_____________________________________________________________________________________________________
'++++++ A0 ---- PARCOURIR INBOX à la recherche de MAILS
'______________________________________________________________________________________________________
For Each MonMail In FldDossier.Items

Dim NMO ' soit NomMailOrigine
Dim NMO2

' ************************* définit date/heure/nom des mails d'origine présents inbox'NMO = "reçu-" & Format(MonMail.ReceivedTime, "dd/mm/yyyy hh:mm:ss") & "_" & MonMail.Subject
'NMO = "reçu-" & Format(MonMail.ReceivedTime, "dd-mm-yyyy hh-mm-ss") & "-" & "Quantum"
NMO2 = "Quantum-recu-" & Format(MonMail.ReceivedTime, "dd-mm-yyyy---hh-mm")

'''========= définit les répertoires de sauvegarde
Dim Chemin8 As String
Chemin8 = "D:\Mails-reçus-TNT-" & JA
If Dir(Chemin8, vbDirectory + vbHidden) = "" Then MkDir Chemin8 '...si le DOSSIER n'existe pas,le créer


Dim Chemin9 As String
Chemin9 = "D:\Mails-reçus-TNT-" & JAPREC
If Dir(Chemin9, vbDirectory + vbHidden) = "" Then MkDir Chemin9

'_________________________________________________________________________________________________________
'A2 ========= SAUVEGARDE RESTRICTION PERIODE DE RECEPTION des mails
'_______ici mails reçus entre 06.00 et 24.00 jour en cours________classés le JOUR EN COURS_____
'_________________________________________________________________________________________________________

'======'Ici on supprime les caractères non autorisé dans les noms de fichiers
Dim PathNMO_JA
PathNMO_JA = Chemin8 & "\" & Left _
(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NMO2, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), _
vbTab, ""), Chr(7), ""), 160) & ".Msg"

If Format(MonMail.ReceivedTime, "dd-mm-yyyy hh:mm") _
> Format(JARUPT, "dd-mm-yyyy hh:mm") And _
Format(MonMail.ReceivedTime, "dd-mm-yyyy hh:mm") _
< Format(JAF, "dd-mm-yyyy hh:mm") Then

FileSaveName = PathNMO_JA
MonMail.SaveAs FileSaveName, olMsg

'_________________________________________________________________________________________________________
'A2 ========= SAUVEGARDE RESTRICTION PERIODE DE RECEPTION des mails
'_______ici mails reçus entre 00.00 et 06.00 jour en cours________classés le jour avant_____
'_________________________________________________________________________________________________________'======'Ici on supprime les caractères non autorisé dans les noms de fichiers
Dim PathNMO_JAPREC
PathNMO_JAPREC = Chemin9 & "\" & Left _
(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NMO2, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), _
vbTab, ""), Chr(7), ""), 160) & ".Msg"
'======' Applique la restriction
If Format(MonMail.ReceivedTime, "dd-mm-yyyy hh:mm") _
> Format(JAD, "dd-mm-yyyy hh:mm") And _
Format(MonMail.ReceivedTime, "dd-mm-yyyy hh:mm") _
< Format(JARUPT, "dd-mm-yyyy hh:mm") Then
'=======' Archive le jour précedent le jour d'analyse
FileSaveName = PathNMO_JAPREC
MonMail.SaveAs FileSaveName, olMsg
End If ' fin de la restriction sur jour en cours
End If ' fin de la restriction sur jour précédent
'_____________________________________________________________________________________________________
'++++++ A0 ---- PARCOURIR INBOX à la recherche de MAILS - suite de la boucle
'______________________________________________________________________________________________________

Next MonMail ' recherche du mail suivant


'Vide des instances
Set MonApply = Nothing
Set MonNSpace = Nothing
Set FldDossier = Nothing
Set MonMail = Nothing

End Sub