Déplacer mail et créer dossier

Poste le code que tu as modifié. Note que "ça ne marche pas " n'aide pas. Que se passe-t-il ? Y a-t-il un message d'erreur ? Le dossier n'est pas créé ?

C'est bon j'ai presque trouvé ! Mnt ce dossier doit être créé dans un sous dossier de "02_DOSSIERS" ce qui n'est pas le cas.

Actuellement ca créé dans la "Boite de réception" et non dans la dossier "02_DOSSIERS"...

On y est presque !

Sub Extraction()

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)

    For Each olmail In olInbox.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 & "\" & pceJointe
                 '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

  Dim NS As Namespace, Dossier As Object, I As MailItem
  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 Worksheets("FICHE ENTETE CLIENT").Range("C4") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C5") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C6") & " - " & Worksheets("FICHE CDE PRM").Range("C70")
      End If
      On Error GoTo 0
      I.Move Dossier.Folders(Worksheets("FICHE ENTETE CLIENT").Range("C4") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C5") & " - " & Worksheets("FICHE ENTETE CLIENT").Range("C6") & " - " & Worksheets("FICHE CDE PRM").Range("C70"))
     End If
  Next I

End Sub

Et est ce qu'on peut importer uniquement des fichiers pdf, excel ? Ca importe aussi les images des signatures :p

On avance, je viens de trouver une solution pour supprimer les jpg et png.

Finalement il me reste le sujet concernant le sous dossier et on est plus que bon !

Sub Suppression()

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

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

Dim oFSO As Object
Dim oDossier As Object
Dim oFichier As Object
Dim i As Integer

Set oFSO = CreateObject("Scripting.FileSystemObject")

Set oDossier = oFSO.GetFolder(utilisateur)

For Each oFichier In oDossier.Files

If oFichier Like "*.jpg" Then
Kill utilisateur & "\" & "*.jpg"
Else
End If

If oFichier Like "*.png" Then
Kill utilisateur & "\" & "*.png"
Else
End If

Next oFichier

End Sub

Essaie

Sub Extraction()

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 NomDossier As String
    Dim y As Integer, x As Integer
    With Sheets("FICHE ENTETE CLIENT")
      NomDossier = .Range("C4") & " - " & .Range("C5") & " - " & .Range("C6") & _
      Sheets("FICHE CDE PRM").Range("C70")
    End With
    Set olApp = New Outlook.Application
    Set olSpace = olApp.GetNamespace("MAPI")
    Set olInbox = olSpace.GetDefaultFolder(olFolderInbox)

    For Each olmail In olInbox.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 & "\" & pceJointe
                 '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

  Dim NS As Namespace, Dossier As Object, I As MailItem
  Set NS = olApp.GetNamespace("MAPI")
  Set Dossier = NS.GetDefaultFolder(olFolderInbox)
  With Worksheets("FICHE ENTETE CLIENT")
    For Each I In Dossier.Items
       If InStr(1, I.Categories, "Nouvelle Affaire") > 0 Then
        On Error Resume Next
        If Dossier.Folders("02_DOSSIERS").Folders("Nouvelle Affaire") Is Nothing Then
          Dossier.Folders("02_DOSSIERS").Folders.Add NomDossier
        End If
        On Error GoTo 0
        I.Move Dossier.Folders("02_DOSSIERS").Folders(NomDossier)
       End If
    Next I
  End With

End Sub

P.A.R.F.A.I.T.

Merci beaucoup !!