AdvancedSearch Outlook VBA par Catégorie

Bonjour, je souhaite faire une recherche avancée sur Outlook en VBA en faisant la recherche uniquement par catégorie.

Je souhaite obtenir tous les emails qui sont catégorisés "DANEMARK" par exemple et je suis bloqué.

Voici le code :

Dim MonScope, MonFiltre As String
Dim resultats As Outlook.Results

MonScope = "'" & myFolder.FolderPath & "'"

MonFiltre = "@SQL=" & Chr(34) _
& "urn:schemas-microsoft-com:office:office#Keywords" & Chr(34) _
& " = 'DANEMARK'"

Set objSch = myOIApp.AdvancedSearch(Scope:=MonScope, Filter:=MonFiltre)

Set resultats = objSch.Results

J'ai un problème au niveau de ma recherche...

Pouvez-vous m'aider svp ? C'est assez urgent please. Merci bien !

Re,

Où en es-tu par rapport à cette demande et la précédente ?

Baboutz

Bonjour merci,

J'arrive a faire une faire une restriction sur l'ensemble de ma boite email avec .Restrict sur la Catégorie de l'email et il faut qu'il soit lu.

Je suis maintenant bloqué sur la date. J'aimerais récupérer uniquement les emails qui ont un temps de présence de plus de 5 jours dans la boite de réception.

Global Mes_Emails_Categorises As Outlook.Items
Global MaCategorie As Range
Global i As Integer
Global DerniereLigne As Integer
Global Categorie_A_Chercher As String
Global Nom_Boite_Email As Recipient
Global Mon_Namespace As Outlook.Namespace
'--------------------------------------------

'Function Deplacement_Email_Categorise(Ma_Categorie_Email As String)
Function Deplacement_Email_Categorise()

    Dim WS_Parametres As Worksheet

    Dim ligne As Integer

    Set WS_Parametres = ActiveWorkbook.Sheets("Parametres")

    Set Nom_Boite_Email = Mon_Namespace.CreateRecipient("maboiteEmail@yahoo.com")
    Set myFolder = Outlook.Application.Session.GetSharedDefaultFolder(Nom_Boite_Email, olFolderInbox)

    'If IsError(Application.Match(Categorie_A_Chercher, Range("A1:A" & DerniereLigne).Value, 0)) Then Exit Function

        'ligne = Application.Match(MaCategorie, WS_Parametres.Columns(1), 0)
        ligne = Application.Match(Categorie_A_Chercher, Range("A1:A" & DerniereLigne).Value, 0)

        If (WS_Parametres.Cells(ligne, 2) <> "") And (WS_Parametres.Cells(ligne, 3) = "") And (WS_Parametres.Cells(ligne, 4) = "") Then

            Set myFolderDestination = myFolder.Folders(CStr(WS_Parametres.Cells(ligne, 2)))

        ElseIf (WS_Parametres.Cells(ligne, 2) <> "") And (WS_Parametres.Cells(ligne, 3) <> "") And (WS_Parametres.Cells(ligne, 4) = "") Then

            Set myFolderDestination = myFolder.Folders(CStr(WS_Parametres.Cells(ligne, 2))).Folders(CStr(WS_Parametres.Cells(ligne, 3)))

        Else

            Set myFolderDestination = myFolder.Folders(CStr(WS_Parametres.Cells(ligne, 2))).Folders(CStr(WS_Parametres.Cells(ligne, 3))).Folders(CStr(WS_Parametres.Cells(ligne, 4)))

        End If

        Mes_Emails_Categorises(i).Move myFolderDestination

        'On remet de le dossier de rangement à la string vide
        'Set myFolderDestination = ""

    'End If

End Function

Sub Rangement_Emails_Categorises_Lus_Dans_Dossiers_Respectifs()

    '********************************************
    'Déclaration des variables pour Outlook Email
    '********************************************
    'Dim myOIApp As Outlook.Application
    Dim myFolder As Outlook.MAPIFolder
    'Dim myFolderDestination As Outlook.MAPIFolder
    'Dim myItems As Outlook.Items
    'Dim myItem As Object
    'Dim myItem As Outlook.MailItem
    'Dim myItems As Object

    '**********************************************************
    'Déclaration des variables pour la boîte Email et NameSpace
    '**********************************************************
    'Dim Nom_Boite_Email As Recipient
    'Dim Mon_Namespace As Outlook.Namespace

    '*******************************************************************************************************************************************************
    'Déclaration des variables de "Temps_Presence_Email" et "Temps_Seuil_Rangement" pour le traitement des Emails
    '"Temps_Presence_Email" indique le nombre de jours où l'email est présent dans la boîte de réception depuis sa réception jusqu'à l'execution de la macro
    '"Temps_Seuil_Rangement" indique le nombre de jours au minimum où les emails seront traités. Il faut un temps de présence d'au moins 5 jours par défaut
    'Si Temps_Presence_Email = 7 jours  et que Temps_Seuil_Rangement = 5 jours, alors l'email sera traité (Temps_Presence_Email) >= Temps_Seuil_Rangement)
    '*******************************************************************************************************************************************************
    Dim Temps_Presence_Email, Temps_Seuil_Rangement As Double

    'Compteur i pour indiquer le nombre d'emails traités. Bien et utile pour le débogage
    Dim k As Integer

    Dim MacroDebut1, MacroDebut2 As Date
    MacroDebut1 = Now
    MacroDebut2 = Now

    'Définition des paramétrages Outlook Application et NameSpace
    Set myOIApp = CreateObject("Outlook.Application")
    Set Mon_Namespace = Outlook.Application.GetNamespace("MAPI")

    'Définition du répertoire "Boîte de réception" dans la boîte emails "maboiteEmail@yahoo.com"
    'Set Nom_Boite_Email = Mon_Namespace.CreateRecipient("maboiteEmail@yahoo.com")
    Set Nom_Boite_Email = Mon_Namespace.CreateRecipient("maboiteEmail@yahoo.com")
    Set myFolder = Outlook.Application.Session.GetSharedDefaultFolder(Nom_Boite_Email, olFolderInbox)

     Dim objSch As Outlook.Search

     'Dim DerniereLigne As Integer

     Dim MonScope, MonFiltre As String

     'Dim MaCategorie As Range

     Dim olDossier As Outlook.MAPIFolder

     DerniereLigne = ActiveWorkbook.Sheets("Parametres").Range("A" & Rows.Count).End(xlUp).Row

     For Each MaCategorie In ActiveWorkbook.Sheets("Parametres").Range("A2:A" & DerniereLigne)

'     start_date = (Date - 4) & Space(1) & "12:00:00"
'     end_date = Date & Space(1) & "23:00:00"

     'Filter = "urn:schemas:httpmail:subject LIKE '%Trade Report automatisch erstellt am%'" & _
     "AND urn:schemas:httpmail:datereceived >= '" & start_date & _
     "' AND urn:schemas:httpmail:datereceived <= '" & end_date & "'"

     Categorie_A_Chercher = CStr(MaCategorie)

     MsgBox (MaCategorie)

      Set myItems = myFolder.Items

      'Les 3 prochaines lignes de codes utiles pour le débogage permettent d'avoir l'objet, la catégorie et la date et heure de réception de l'Email
      'MsgBox (myItems.Subject)
      'MsgBox (myItems.Categories)
      'MsgBox (myItems.ReceivedTime)

      'Set Mes_Emails_Categorises = myItems.Restrict("[Categories] = " & CStr(MaCategorie) & " AND [UnRead] = False")
      Set Mes_Emails_Categorises = myItems.Restrict("[Categories] = " & CStr(MaCategorie) & " AND [UnRead] = False AND " & CDbl(DateDiff("d", myItem.[ReceivedTime], Now)) & ">5")

        For i = Mes_Emails_Categorises.Count To 1 Step -1

          'MsgBox (Mes_Emails_Categorises.Class)
          Call Deplacement_Email_Categorise
          k = k + 1

        Next

        'Set myFolderDestination = Nothing

      Next

      MsgBox "Durée d'exécution: " & Format(Now - MacroDebut2, "hh:mm:ss")

1) Je suis en plein test. Je bloque sur le filtre dans ma boucle car je veux arriver a a filtrer sur les emails qui sont présents dans la boite de reception de plus de 5 jours.

2) J'ai un autre problème c'est concernant ma fonction de déplacement de mail... En fait j'ai des catégories dans une colonne sur mon fichier excel. on parcourt chaque catégorie et pour chaque catégorie il y a son dossier de rangement.

Quand je défini "myFolderDestination" et qu'il boucle pour les autres catégories, j'ai un message d'erreur "Echec de l'opération. Impossible de trouver un objet".

Par exemple la premiere fois : "Danemark = Boite de reception/DANEMARK" et ensuite pour la bulgarie c'est "Boite de reception/BULGARIE" alors que j'ai "DANEMARK = Boite de reception/BULGARIE"... Je veux qu'il remmette a "Rien" le myFolderDestination.

Comment faire ? Merci

Set myFolderDestination = myFolder.Folders(CStr(WS_Parametres.Cells(ligne, 2))

Re,

On essaie de clore le problème que tu as rencontré sur l'autre post, puis on voit ici si tu rencontres d'autres difficultés sur le sujet.

À toute,

Baboutz