none
Outlook crée un dossier si inexistant RRS feed

  • Question

  • Bonjour, 

    J'utilise une macro de déplacement de mail après envoi dans un dossier à la date du jour. Mais j'aimerais ajouter une condition pour que si le dossier n'existe pas il soit crée automatiquement.

    Voici mon code :

     Private Sub maBoiteEnvoi_ItemAdd(ByVal Item As Object)
        Dim oDossier As Outlook.MAPIFolder
        Dim oDossiers As Outlook.MAPIFolder
        Dim Ol_App As New Outlook.Application
        Dim Ol_MAPI As Outlook.NameSpace
        Dim Ol_FolderFrom As Outlook.MAPIFolder
        Dim Ol_FolderTo As Outlook.MAPIFolder
        Dim Ol_Items As Outlook.MailItem
        
        jour = Day(Date)
        If jour < 10 Then
        jour = "0" & jour
        End If
        mois = Month(Date)
        If mois < 10 Then
        mois = "0" & mois
        End If
        mois2 = Month(Date)
        mois2 = Format(Date, "mmmm")
        annee2 = Year(Date)
        annee2 = Format(Date, "yyyy")
        annee = Year(Date)
        annee = Right(annee, 2)
      
        madate = jour & "." & mois & "." & annee
        madate2 = mois & " " & mois2 & " " & annee2
        madate3 = mois & " " & mois2
        Enrg = InputBox("Dans quel dossier déplacer ce mail ? " & vbCr & "Boite commune entrez : '1'" & vbCr & "Boite CG75 entrez : '2'", "Déplacer ce mail")
    
        Set oNS = Application.GetNamespace("MAPI")
        Set Ol_MAPI = Ol_App.GetNamespace("MAPI")
        Set oDossier = Ol_MAPI.Folders("Boîte aux lettres").Folders("Boîte de réception").Folders("NOUVELLE BOITE").Folders(madate2).Folders("Traités").Folders("Mike").Folders(madate)
        Set oDossiers = Ol_MAPI.Folders("Boîte aux lettres").Folders("Inbox").Folders("BOITE DE TRAITEMENT ET ARCHIVE").Folders("2014").Folders(madate3).Folders("TRAITE").Folders("Mike").Folders(madate)
        If Enrg = "1" Then
           Item.Move oDossier
        ElseIf Enrg = "2" Then
          Item.Move oDossiers
          If Not oDossier Is Nothing Then
            End If
        End If
        
             
         
        Set oDossier = Nothing
        Set oDossiers = Nothing
        
           
    End Sub

    Merci d'avance pour votre aide.

    Cdt

    lundi 13 janvier 2014 11:50

Réponses

Toutes les réponses