Sub Ouverture()
     
    Dim myCases As String
    Dim myDirectory As String
    Dim fullPathCreation As String
    'Spécifier ici le répertoire dans lequel vous voulez créer les tickets (ce répertoire doit déjà exister)
    myCases = "Tickets"
    'Spécifier le répertoire local correspondant au ticket
    myDirectory = "D:\TICKETS\Test\"
         
         
    Dim myolApp As Outlook.Application
    Dim myNamespace As Outlook.NameSpace
     
    'Création du nouveau dossier dans le répertoire indiqué précedemment
    Set myolApp = CreateObject("Outlook.Application" )
    Set myNamespace = myolApp.GetNamespace("MAPI" )
    'Demande à l'utilisateur le numéro de ticket
    FolderName = InputBox("Indiquer le numéro du ticket :" )
    Set objStrCtc = myNamespace.GetDefaultFolder(olFolderInbox).Folders(myCases).Folders.Add(FolderName, olFolderInbox)
    objStrCtc.ShowAsOutlookAB = True
    'Création du répertoire local
    fullPathCreation = myDirectory + FolderName
    If Len(Dir(fullPathCreation, vbDirectory)) = 0 Then
        MkDir fullPathCreation
    End If
     
    Dim colRules As Outlook.Rules
    Dim oRule As Outlook.Rule
    Dim colRuleActions As Outlook.RuleActions
    Dim oMoveRuleAction As Outlook.MoveOrCopyRuleAction
    Dim oExceptSubject As Outlook.TextRuleCondition
    Dim oInbox As Outlook.Folder
    Dim oMoveTarget As Outlook.Folder
 
    'Selectionne le folder cible de la règle
    Set oInbox = Application.Session.GetDefaultFolder(olFolderInbox)
    Set oMoveTarget = oInbox.Folders(myCases).Folders(FolderName)
     
    'Récupère les règles existantes
    Set colRules = Application.Session.DefaultStore.GetRules()
     
    'Créer les règles IN et OUT
    Set oRuleIn = colRules.Create(FolderName + "_IN", olRuleReceive)
    Set oRuleOut = colRules.Create(FolderName + "_OUT", olRuleSend)
 
    'Définition la règle IN
    Set oExceptSubject = oRuleIn.Conditions.Subject
    With oExceptSubject
        .Enabled = True
        .Text = Array(FolderName)
    End With
     
        Set oMoveRuleAction = oRuleIn.Actions.MoveToFolder
    With oMoveRuleAction
        .Folder = oMoveTarget
        .Enabled = True
    End With
       
    'Définition la règle OUT
    Set oExceptSubject = oRuleOut.Conditions.Subject
    With oExceptSubject
        .Enabled = True
        .Text = Array(FolderName)
    End With
 
    Set oMoveRuleAction = oRuleOut.Actions.MoveToFolder
    With oMoveRuleAction
        .Folder = oMoveTarget
        .Enabled = True
    End With
     
    'Update the server and display progress dialog
    colRules.Save
     
End Sub

  'Définition la règle OUT
    Set oExceptSubject = oRuleOut.Conditions.Subject
    With oExceptSubject
        .Enabled = True
        .Text = Array(FolderName)
    End With
 
    Set oMoveRuleAction = oRuleOut.Actions.MoveToFolder
    With oMoveRuleAction
        .Folder = oMoveTarget
        .Enabled = True
    End With