Déplacer mail et créer dossier

Bonjour,

Je recherche une macro pour créer un dossier outlook à partir de la valeur de la cellule A1 ou une variable que je peux indiquer dans la macro.

Tous les mails du dossier existant déjà sur Outlook "00_NOUVEAUX DOSSIERS" ce déplace automatique dans ce nouveau dossier.

J'ai cherché sur les forums mais rien ne marche...

Un test pour créer un dossier mais ca ne marche déjà pas..

Dim monOutlook
Set monOutlook = Outlook.Application
Dim ns As Namespace
Set ns = monOutlook.GetNamespace("MAPI")
Dim dossier As MAPIFolder
Set dossier = ns.Folders("00_NOUVEAUX DOSSIERS")
Dim myNewFolder As MAPIFolder
Set myNewFolder = dossier.Folders.Add("Test")
 

Merci !

Bonjour,

Comment se situe le dossier par rapport à la boîte de réception ? Peux-tu publier une image de l'arborescence ?

Daniel

Essaie :

Sub CreerDossier()
  Dim NS As Namespace, olApp As Object, Dossier As Object
  Set olApp = Outlook.Application
  Set NS = olApp.GetNamespace("MAPI")
  Set Dossier = NS.GetDefaultFolder(olFolderInbox).Folders("00_NOUVEAUX DOSSIERS")
  Dossier.Folders.Add "Test"
End Sub

Daniel

Ca marche ! Top :)

Est ce possible mnt de....

Créer un dossier à partir d'un mail avec une catégorie "Nouvelle Affaire" dans ma boite de réception principal.

Créer un sous dossier (comme ta macro) et de déplacer ce mail dans ce nouveau dossier ?

Ca serait parfait !

Bonjour,

Je ne suis pas un pro de outlook. C'est quoi la catégorie d'un mail ?

Daniel

Clique droit sur un mail.

Je n'ai pas cette option dans le menu contextuel mais je vais regarder. Donc la macro s'exécuterait à partir d'un message sélectionné ?

Daniel

... Ou, est-ce qu'il faut examiner tous les mails ? Quel sera le nom du nouveau sous-dossier ?

Daniel

Le nouveau dossier peut prendre le nom de la cellule A1

Il faut examiner tous les mails dans la boite de réception “classique”

Besoin d'autres informations ...?

La macro suivante lit les messages de la boîte de réception. Si l'une des catégories est égale à "Nouvelle affaire", le sous-dossier est créé s'il n'existe pas et les messages sont déplacés dans ce dossier.

Sub CreerDossier2()
  Dim NS As Namespace, olApp As Object, Dossier As Object, I As MailItem
  Set olApp = Outlook.Application
  Set NS = olApp.GetNamespace("MAPI")
  Set Dossier = NS.GetDefaultFolder(olFolderInbox)
  For Each I In Dossier.Items
     If InStr(1, I.Categories, "Nouvelle affaire") > 0 Then
      On Error Resume Next
      If Dossier.Folders("Nouvelle affaire") Is Nothing Then
        Dossier.Folders.Add "Nouvelle affaire"
      End If
      On Error GoTo 0
      I.Move Dossier.Folders("Nouvelle affaire")
     End If
  Next I
End Sub

Daniel

Parfait ! Est ce que ce nouveau dossier peut être considéré comme un sous-dossier de "02_DOSSIERS" ?

Encore une dernière chose...et après c'est parfait ! Est ce qu'on peut extraire les PJ du mail et le sauvegarder sur un dossier lambda sur le bureau ?

Encore merci !

J'ai déjà une macro qui marche mais n'est pas adapté...

Option Explicit
Option Compare Text
Sub Extraction(NomDossier As String, Expediteur As String)

Dim utilisateur As String
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")

utilisateur = oWSHShell.SpecialFolders("Desktop") & "\"

    Dim olApp As Outlook.Application
    Dim olSpace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olInbox As Outlook.MAPIFolder
    Dim olmail As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment

    Dim y As Integer, x As Integer

    Set olApp = New Outlook.Application
    Set olSpace = olApp.GetNamespace("MAPI")
    Set olInbox = olSpace.GetDefaultFolder(olFolderInbox)
    Set olFolder = olInbox.Folders(NomDossier)

    For Each olmail In olFolder.Items
        'If olmail.SenderEmailAddress = Expediteur And _
            'Not olmail.Attachments.Count = 0 Then

            For y = 1 To olmail.Attachments.Count
                 Set pceJointe = olmail.Attachments(y)
                 x = x + 1
                 'pas d'affichage de x avant le nom de la PJ ça c'est mon commentaire pense bète pendant les essais...
                 pceJointe.SaveAsFile utilisateur & "\" & Worksheets("FICHE ENTETE CLIENT").Range("C4") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C5") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C6") & " - " & Worksheets("FICHE CDE PRM").Range("C70") & "\Plans recus\" & pceJointe
                Set pceJointe = Nothing
            Next y
        'End If
    Next olmail

End Sub

Il faut intégrer ma macro à la tienne ? (je n'avais pas vu pour prendre le nom du dossier dans la cellule A1).

Daniel

Peut importe la valeur de la cellule A1, c'est pour l'exemple.

Oui si possible :). J'ai essayé mais j'y arrive tjr pas :p

Essaie :

Sub Extraction(NomDossier As String, Expediteur As String)

Dim utilisateur As String
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")

utilisateur = oWSHShell.SpecialFolders("Desktop") & "\"

    Dim olApp As Outlook.Application
    Dim olSpace As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olInbox As Outlook.MAPIFolder
    Dim olmail As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment

    Dim y As Integer, x As Integer

    Set olApp = New Outlook.Application
    Set olSpace = olApp.GetNamespace("MAPI")
    Set olInbox = olSpace.GetDefaultFolder(olFolderInbox)
    Set olFolder = olInbox.Folders(NomDossier)

    For Each olmail In olFolder.Items
        'If olmail.SenderEmailAddress = Expediteur And _
            'Not olmail.Attachments.Count = 0 Then

            For y = 1 To olmail.Attachments.Count
                 Set pceJointe = olmail.Attachments(y)
                 x = x + 1
                 'pas d'affichage de x avant le nom de la PJ ça c'est mon commentaire pense bète pendant les essais...
                 pceJointe.SaveAsFile utilisateur & "\" & Worksheets("FICHE ENTETE CLIENT").Range("C4") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C5") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C6") & " - " & Worksheets("FICHE CDE PRM").Range("C70") & "\Plans recus\" & pceJointe
                Set pceJointe = Nothing
            Next y
        'End If
      If InStr(1, olmail.Categories, "Nouvelle affaire") > 0 Then
        On Error Resume Next
        If olInbox.Folders("Nouvelle affaire") Is Nothing Then
          olInbox.Folders.Add "Nouvelle affaire"
        End If
        On Error GoTo 0
        olmail.Move Dossier.Folders("Nouvelle affaire")
      End If
    Next olmail

End Sub

Daniel

Ca ne marche pas, est ce possible de supprimer ca :

Sub Extraction(NomDossier As String, Expediteur As String)

Et de le faire devenir une macro "classique" avec Sub Extraction()

J'ai essayé de les convertir de mon côté mais ca bloque ici :

Set olFolder = olInbox.Folders(NomDossier)

Bonjour,

La ligne ;

Sub Extraction(NomDossier As String, Expediteur As String)

signifie que la macro attend deux paramètres, "NomDossier" et "Expediteur". Ce dernier n'est pas utilisé dans le code actuel. Par contre, tu te sers de "NomDossier" pour spécifier un sous-dossier de la boîte de réception. Ensuite, tu boucles sur les messages de ces dossiers pour enregistrer les pièces jointes. Dans cette boucle j'ai ajouté le tes sur les catégories.

Tu ne peux donc pas lancer directement la macro telle quelle. Tu dois mettre ;

Sub Extraction()

Et ajouter en début de macro :

NomDossier As String
NomDossier= "ici, mets le nom du dossier"

En indiquant le nom du dossier voulu.

Daniel

Mon dossier sera créé en fonction de la valeur de ca

Worksheets("FICHE ENTETE CLIENT").Range("C4") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C5") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C6") & " - " & Worksheets("FICHE CDE PRM").Range("C70")

Le mail que doit récupérer la macro pour importer les pj et créer le sous dossier pour le déplacer n'a pas de contrainte lié au nom.

La seule contrainte est la catégorie : "Nouvelle Affaire"

Ca marche tjr pas :p