Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

Outlook Macro Outlook 365-Création sous-dossier suivant contenu et sauvegarde pièces jointes lien zip

Créer une discussion

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
D

DELATTE

XLDnaute Nouveau
Bonjour chers développeurs,

Je fais à nouveau appel à vous pour savoir si il est possible d'automatiser une tâche dans Outlook via Macro.

Chaque jour, nous recevons des mails automatiques avec un texte standardisé comme l'exemple ci-dessous :

"Madame, Monsieur,

Veuillez trouver ci-dessous un lien vers un fichier ZIP qui contient la facture électronique (fichier XML faisant foi d'un point de vue légal) reçue ainsi que le fichier PDF généré par nos soins qui affiche les données essentielles de cette facture et d'éventuelles pièces jointes à la facture par l'émetteur :

•​
20241204_facture électronique_20241086.zip
Données clés contenues dans la facture :

•​
N°/Identifiant de la facture :20241086
•​
Émetteur :Fournisseur XX
•​
Identifiant Peppol de l’émetteur :123456
•​
Date d’émission de la facture :04-12-2024
•​
Date de réception effective :04-12-2024
•​
Destinataire :Client ZZ
•​
Identifiant Peppol du destinataire :LU456789
•​
Montant total TTC :100.00 EUR

Je voulais savoir si il était possible de créer automatiquement un sous dossier Outlook basé sur le nom de l'émetteur (Founisseur XX) en sachant que mon arborescence outlook se présente ainsi : Accounting/2024/Fournisseurs/12.2024/Nom du fournisseur. La date de l'émission de la facture représente le classement du mois.
Dans un deuxième temps, est-il possible d'ouvrir par macro le lien zip pour sauvegarder les pièces jointes dans un folder windows suivant le nom suivant : Nom de l'émetteur_numéro de facture_Pièce 1, Pièce 2....

Un grand merci pour votre aide toujours géniale.

Bien à vous,
 
Solution
DELATTE à dit:
Et le mail ne se déplace pas de la boîte de réception dans l'arborescence Outlook.
Cliquez pour agrandir...
Normal, l'option était désactivé en début de code :

DELATTE à dit:
Si je peux encore abuser de votre temps, est-il possible que les fichiers contenus dans le lien zip soient renommés comme ci-dessous (Nom fournisseur_Numéro facture_ 01, 02, 03) et rangés directement dans le dossier Test ?:
Cliquez pour agrandir...
Modif effectuée, si vous avez encore à déplacer le dossier cible, agissez sur la ligne :

Attention, les sous dossiers déjà créés existent toujours, à vous de les détruire

DELATTE à dit:
Si je peux encore abuser de votre temps, est-il possible que les fichiers contenus dans le lien zip soient renommés comme ci-dessous (Nom fournisseur_Numéro...
Cliquez pour agrandir...
Trier par date Trier par votes
Testez le code ci-joint :
Je l'ai éprouvé avec l'e-mail fourni ...
VB: 
Option Compare Text
Const Emetteur = "info@efact.public.lu"
Const Destinataire = "accounting@societe.lu"
'Const Emetteur = "francois.lheritier95@free.fr"
'Const Destinataire = "test.vba.fanch55@free.fr"


Sub Exec_Manuel() ' Lancement manuel à partir de la  boite de réception
Dim Bal As Outlook.Items, Mail As Outlook.MailItem
    On Error Resume Next
        Set Bal = GetNamespace("Mapi").Stores(Destinataire).GetDefaultFolder(olFolderInbox).Items
        If Bal Is Nothing Then
            MsgBox "Le destinataire " & Destinataire & vbLf _
                 & " n'existe probablement pas ...." & vbLf & vbLf _
                 & Err.Number & vbLf _
                 & Err.Description, vbCritical
        Else
            On Error GoTo 0
            Set Mail = Bal.Find("[SenderEmailAddress]=""" & Emetteur & """")
            If Not Mail Is Nothing Then Script_Delatte Mail
        End If
        
End Sub

Sub Script_Delatte(Mail As Outlook.MailItem)
Dim Folder   As Outlook.MAPIFolder
Dim An As String, Mois As String, Facture As String
Dim Target_Folder As Variant, Zip_File As Variant, Zip_Source As Variant, Line As Variant
Dim Tampon() As Byte

Dim L As Integer, Requis As Integer

Select Case True
    Case Not Mail.ReceivedByName = Destinataire
    Case Not Mail.SenderEmailAddress = Emetteur
    Case Else
        Debug.Print "Incoming " & Mail.Subject _
                  & " from " & Mail.SenderEmailAddress _
                  & " to " & Mail.ReceivedByName
        Line = Split(Mail.Body, vbCrLf & vbCrLf)
        For L = 0 To UBound(Line)
            Select Case True
            Case Trim(Line(L)) Like "N°*": Requis = Requis + 1
                Facture = Trim(Line(L + 1))
                Debug.Print , "Facture trouvée ( " & Facture & ") "
            
            Case Trim(Line(L)) Like "*.zip *": Requis = Requis + 1
                Z = Split(Line(L), "<")
                Zip_File = Trim(Z(0))
                Zip_Source = Trim(Replace(Z(1), ">", ""))
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
            
            Case Trim(Line(L)) Like "*émission de la facture*":
                W = Split(Trim(Line(L + 1)), "-")
                If UBound(W) < 2 Then
                    MsgBox "Date de facture incorrecte : " & Line(L + 1) & vbLf & "Abandon ....", vbCritical
                Else
                    Mois = W(1)
                      An = W(2)
                    Debug.Print , "Mois et An trouvés ( " & Mois & "/" & An & " )"
                    Requis = Requis + 1
                End If
            
            Case Trim(Line(L)) = "Émetteur :": Requis = Requis + 1
                Fournisseur = Trim(Line(L + 1))
                Debug.Print , "Fournisseur trouvé (" & Fournisseur & ")"
                
            Case Requis = 4
                Debug.Print "      Tous les requis sont acquis"
                Debug.Print , "Construction de l'arborescence outlook"
'               Construction de l'arborescence s'il le faut
                Set Folder = Set_Outlook_Folder(GetNamespace("Mapi").folders(Mail.ReceivedByName), _
                        "Accounting\" & An & "\Fournisseurs\" & Mois & "." & An & "\" & Fournisseur)
                Mail.UnRead = False
'               -------------------------------------------------------------------------------------------------
                Debug.Print , "Archivage du mail dans " & Folder.FolderPath
'               Décommenter la ligne suivante pour déplacer réellement le mail
                Set Mail = Mail.Move(Folder)
'               -------------------------------------------------------------------------------------------------
                ' enregistrement du fichier Zip
                Target_Folder = Set_WinDows_Folder( _
                     "S:\Administration\FOURNISSEURS\Fournisseurs " & An & "\Zip-UNZIP\test\" & Fournisseur & "\" & Facture)
                Zip_File = Target_Folder & Zip_File
                Debug.Print , "Stockage du zip dans " & Target_Folder
                With CreateObject("WinHttp.WinHttpRequest.5.1")
                    .Open "Get", Zip_Source, False
                    .Send
                    If .Status = 200 Then
                        Tampon = .responseBody
                        Fic = FreeFile
                        Open Zip_File For Binary Access Write As #Fic
                        Put #Fic, , Tampon
                        Close #Fic
                        Erase Tampon
                        ' dé-Zippage
                        Debug.Print , "Dézippage"
                        With CreateObject("Shell.Application")
                             ' option 16 pour tout remplacer sans poser de question
                             .NameSpace(Target_Folder).CopyHere .NameSpace(Zip_File).Items, 16
                        End With
                        Debug.Print , "élimination du fichier Zip"
                        Kill Zip_File
                    Else
                        MsgBox "Fichier Zip non trouvé sur le serveur" & vbLf & "Abandon ....", vbCritical
                    End If
                End With
                 
                Exit For
            End Select
        Next
        Debug.Print "Fin de Traitement"
        Debug.Print
    End Select
End Sub

Function Set_Outlook_Folder(Mapi As Outlook.MAPIFolder, Target_Folder As Variant) As Outlook.MAPIFolder
    Dim Folder As Outlook.MAPIFolder
    On Error Resume Next
        For Each N In Split(Target_Folder, "\")
            Set Folder = Mapi.folders(N)
            If Folder Is Nothing Then Set Folder = Mapi.folders.Add(N)
            Set Mapi = Folder
            Set Folder = Nothing
        Next
    On Error GoTo 0
    Set Set_Outlook_Folder = Mapi
End Function

Function Set_WinDows_Folder(Target_Folder)
    Dim Folder
    For Each F In Split(Target_Folder, "\")
        Folder = IIf(Folder = "", "", Folder) & F & "\"
        If Dir(Folder, vbDirectory) = "" Then MkDir Folder
    Next
    Set_WinDows_Folder = Folder
End Function
 
Dernière édition:
Vote positif 0 Vote négatif
 
Vote positif 0 Vote négatif
Je ne pense pas que ce soit un pb de droits à ce niveau, on n'a rien tenté de créer encore .
Ce serait plutôt Outlook 365 qui ne fournit pas exactement la même chose que Outlook 2021 .
Testez le code ci-dessous; il va créer un fichier Trace_Body.txt dans votre espace Documents, Pourriez-vous me l'envoyer ?
VB: 
Option Compare Text
Const Emetteur = "info@efact.public.lu"
Const Destinataire = "accounting"
Const Disque_Local = "S" ' nom du volume sur lequel stocker les fichiers dézippés
Const Move_Mail = False  ' mettre à True pour déplacer effectivement le mail

Sub Exec_Manuel() ' Lancement manuel à partir de la  boite de réception
Dim Bal As Outlook.Items, Mail As Outlook.MailItem
    On Error Resume Next
        Set Bal = GetNamespace("Mapi").Stores(Destinataire).GetDefaultFolder(olFolderInbox).Items
        If Bal Is Nothing Then
            MsgBox "Le destinataire " & Destinataire & vbLf _
                 & " n'existe probablement pas ...." & vbLf & vbLf _
                 & Err.Number & vbLf _
                 & Err.Description, vbCritical
        Else
            On Error GoTo 0
            Set Mail = Bal.Find("[SenderEmailAddress]=""" & Emetteur & """")
            If Not Mail Is Nothing Then Script_Delatte Mail
        End If
       
End Sub
Sub Tracer(Line)
    Doc_Folder = CreateObject("Shell.Application").NameSpace(&H5).self.Path
    Fic = FreeFile
    Open Doc_Folder & "\Trace_Body.txt" For Output As #Fic
        For Each Lin In Line
            Print #Fic, Lin
        Next
    Close #Fic
End Sub
Sub Script_Delatte(Mail As Outlook.MailItem)
Dim Folder   As Outlook.MAPIFolder
Dim An As String, Mois As String, Facture As String
Dim Target_Folder As Variant, Zip_File As Variant, Zip_Source As Variant, Line As Variant
Dim Tampon() As Byte

Dim L As Integer, Requis As Integer

Select Case True
    Case Not Mail.ReceivedByName = Destinataire
    Case Not Mail.SenderEmailAddress = Emetteur
    Case Else
        Debug.Print "Incoming " & Mail.Subject _
                  & " from " & Mail.SenderEmailAddress _
                  & " to " & Mail.ReceivedByName
     
       ' on remplace d'abord les doubles "retour à la ligne" par un seul
       ' et on éclate le mail en lignes en se basant sur le "retour à la ligne"
        Line = Split(Replace(Mail.Body, vbCrLf & vbCrLf, vbCrLf), vbCrLf)
        Tracer Line
        For L = 0 To UBound(Line)
            Select Case True
            Case Trim(Line(L)) Like "N°*": Requis = Requis + 1
                Facture = Trim(Line(L + 1))
                Debug.Print , "Facture trouvée ( " & Facture & ") "
           
            Case Trim(Line(L)) Like "*.zip *": Requis = Requis + 1
                Z = Split(Line(L), "<")
                Zip_File = Trim(Z(0))
                Zip_Source = Trim(Replace(Z(1), ">", ""))
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
           
            Case Trim(Line(L)) Like "*émission de la facture*":
                W = Split(Trim(Line(L + 1)), "-")
                If UBound(W) < 2 Then
                    MsgBox "Date de facture incorrecte : " & Line(L + 1) & vbLf & "Abandon ....", vbCritical
                Else
                    Mois = W(1)
                      An = W(2)
                    Debug.Print , "Mois et An trouvés ( " & Mois & "/" & An & " )"
                    Requis = Requis + 1
                End If
           
            Case Trim(Line(L)) = "Émetteur :": Requis = Requis + 1
                Fournisseur = Trim(Line(L + 1))
                Debug.Print , "Fournisseur trouvé (" & Fournisseur & ")"
               
            Case Requis = 4
                Debug.Print "      Tous les requis sont acquis , traitement lancé"
               
                ' Construction de l'arborescence de stockage du mail s'il le faut
                Debug.Print , "Construction de l'arborescence outlook"
                Set Folder = Set_Outlook_Folder(GetNamespace("Mapi").folders(Mail.ReceivedByName), _
                        "Accounting\" & An & "\Fournisseurs\" & Mois & "." & An & "\" & Fournisseur)
                Mail.UnRead = False
               
                ' Déplacement ou non du Mail
                If Move_Mail Then
                    Debug.Print , "Archivage du mail dans " & Folder.FolderPath
                    Set Mail = Mail.Move(Folder)
                End If
               
                ' Enregistrement du fichier Zip
                Target_Folder = Set_WinDows_Folder( _
                     Disque_Local & ":\Administration\FOURNISSEURS\Fournisseurs " & An & "\Zip-UNZIP\test\" & Fournisseur & "\" & Facture)
                Zip_File = Target_Folder & Zip_File
                Debug.Print , "Stockage du zip dans " & Target_Folder
                With CreateObject("WinHttp.WinHttpRequest.5.1")
                    .Open "Get", Zip_Source, False
                    .Send
                    If .Status = 200 Then
                        Tampon = .responseBody
                        Fic = FreeFile
                        Open Zip_File For Binary Access Write As #Fic
                        Put #Fic, , Tampon
                        Close #Fic
                        Erase Tampon
                        ' dé-Zippage
                        Debug.Print , "Dézippage"
                        With CreateObject("Shell.Application")
                             ' option 16 pour tout remplacer sans poser de question
                             .NameSpace(Target_Folder).CopyHere .NameSpace(Zip_File).Items, 16
                        End With
                        Debug.Print , "Suppression du fichier Zip"
                        Kill Zip_File
                    Else
                        MsgBox "Fichier Zip non trouvé sur le serveur" & vbLf & "Abandon ....", vbCritical
                    End If
                End With
               
                Exit For
            End Select
        Next
        Debug.Print "Fin de Traitement"
        Debug.Print
    End Select
End Sub

Function Set_Outlook_Folder(Mapi As Outlook.MAPIFolder, Target_Folder As Variant) As Outlook.MAPIFolder
    Dim Folder As Outlook.MAPIFolder
    On Error Resume Next
        For Each N In Split(Target_Folder, "\")
            Set Folder = Mapi.folders(N)
            If Folder Is Nothing Then Set Folder = Mapi.folders.Add(N)
            Set Mapi = Folder
            Set Folder = Nothing
        Next
    On Error GoTo 0
    Set Set_Outlook_Folder = Mapi
End Function

Function Set_WinDows_Folder(Target_Folder)
    Dim Folder
    For Each F In Split(Target_Folder, "\")
        Folder = IIf(Folder = "", "", Folder) & F & "\"
        If Dir(Folder, vbDirectory) = "" Then MkDir Folder
    Next
    Set_WinDows_Folder = Folder
End Function
 
Vote positif 0 Vote négatif
J'étais en "Pétanque" cet après-midi ( retraite oblige .... )
Merci pour le fichier créé, cela confirme mes craintes, outlook 365 ne restitue pas à l'identique les mails que Outlook 2021 .
Le code suivant devrait s'adapter aux deux versions :
VB: 
Option Compare Text
Const Emetteur = "info@efact.public.lu"
Const Destinataire = "accounting"
Const Disque_Local = "S" ' nom du volume sur lequel stocker les fichiers dézippés
Const Move_Mail = False  ' mettre à True pour déplacer effectivement le mail

Sub Exec_Manuel() ' Lancement manuel à partir de la  boite de réception
Dim Bal As Outlook.Items, Mail As Outlook.MailItem
    On Error Resume Next
        Set Bal = GetNamespace("Mapi").Stores(Destinataire).GetDefaultFolder(olFolderInbox).Items
        If Bal Is Nothing Then
            MsgBox "Le destinataire " & Destinataire & vbLf _
                 & " n'existe probablement pas ...." & vbLf & vbLf _
                 & Err.Number & vbLf _
                 & Err.Description, vbCritical
        Else
            On Error GoTo 0
            Set Mail = Bal.Find("[SenderEmailAddress]=""" & Emetteur & """")
            If Not Mail Is Nothing Then Script_Delatte Mail
        End If
        
End Sub
Sub Tracer(Line)
    Doc_Folder = CreateObject("Shell.Application").NameSpace(&H5).self.Path
    Fic = FreeFile
    Open Doc_Folder & "\Trace_Body.txt" For Output As #Fic
        For Each Lin In Line
            Print #Fic, Lin
        Next
    Close #Fic
End Sub
Sub Script_Delatte(Mail As Outlook.MailItem)
Dim Folder   As Outlook.MAPIFolder
Dim An As String, Mois As String, Facture As String
Dim Target_Folder As Variant, Zip_File As Variant, Zip_Source As Variant, Line As Variant
Dim Tampon() As Byte

Dim L As Integer, Requis As Integer

Select Case True
    Case Not Mail.ReceivedByName = Destinataire
    Case Not Mail.SenderEmailAddress = Emetteur
    Case Else
        Debug.Print "Incoming " & Mail.Subject _
                  & " from " & Mail.SenderEmailAddress _
                  & " to " & Mail.ReceivedByName
      
       ' on remplace d'abord les doubles "retour à la ligne" par un seul
       ' et on éclate le mail en lignes en se basant sur le "retour à la ligne"
        'Input_Trace Body
        Body = Mail.Body
        Body = Replace(Body, vbTab, vbCrLf)
        Body = Replace(Body, vbCrLf & vbCrLf, vbCrLf)
        Line = Split(Body, vbCrLf)
        Tracer Line
        For L = 0 To UBound(Line)
            Select Case True
            Case Trim(Line(L)) Like "N°*": Requis = Requis + 1
                Facture = Trim(Line(L + 1))
                Debug.Print , "Facture trouvée ( " & Facture & ") "
            
            Case Trim(Line(L)) Like "*.zip *": Requis = Requis + 1
                Z = Split(Line(L), "<")
                Zip_File = Trim(Z(0))
                Zip_Source = Trim(Replace(Z(1), ">", ""))
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
            
            Case Trim(Line(L)) Like "*émission de la facture*":
                W = Split(Trim(Line(L + 1)), "-")
                If UBound(W) < 2 Then
                    MsgBox "Date de facture incorrecte : " & Line(L + 1) & vbLf & "Abandon ....", vbCritical
                Else
                    Mois = W(1)
                      An = W(2)
                    Debug.Print , "Mois et An trouvés ( " & Mois & "/" & An & " )"
                    Requis = Requis + 1
                End If
            
            Case Trim(Line(L)) = "Émetteur :": Requis = Requis + 1
                Fournisseur = Trim(Line(L + 1))
                Debug.Print , "Fournisseur trouvé (" & Fournisseur & ")"
                
            Case Requis = 4
                Debug.Print "      Tous les requis sont acquis , traitement lancé"
                
                ' Construction de l'arborescence de stockage du mail s'il le faut
                Debug.Print , "Construction de l'arborescence outlook"
                Set Folder = Set_Outlook_Folder(GetNamespace("Mapi").folders(Mail.ReceivedByName), _
                        "Accounting\" & An & "\Fournisseurs\" & Mois & "." & An & "\" & Fournisseur)
                Mail.UnRead = False
                
                ' Déplacement ou non du Mail
                If Move_Mail Then
                    Debug.Print , "Archivage du mail dans " & Folder.FolderPath
                    Set Mail = Mail.Move(Folder)
                End If
                
                ' Enregistrement du fichier Zip
                Target_Folder = Set_WinDows_Folder( _
                     Disque_Local & ":\Administration\FOURNISSEURS\Fournisseurs " & An & "\Zip-UNZIP\test\" & Fournisseur & "\" & Facture)
                Zip_File = Target_Folder & Zip_File
                Debug.Print , "Stockage du zip dans " & Target_Folder
                With CreateObject("WinHttp.WinHttpRequest.5.1")
                    .Open "Get", Zip_Source, False
                    .Send
                    If .Status = 200 Then
                        Tampon = .responseBody
                        Fic = FreeFile
                        Open Zip_File For Binary Access Write As #Fic
                        Put #Fic, , Tampon
                        Close #Fic
                        Erase Tampon
                        ' dé-Zippage
                        Debug.Print , "Dézippage"
                        With CreateObject("Shell.Application")
                             ' option 16 pour tout remplacer sans poser de question
                             .NameSpace(Target_Folder).CopyHere .NameSpace(Zip_File).Items, 16
                        End With
                        Debug.Print , "Suppression du fichier Zip"
                        Kill Zip_File
                    Else
                        MsgBox "Fichier Zip non trouvé sur le serveur" & vbLf & "Abandon ....", vbCritical
                    End If
                End With
                
                Exit For
            End Select
        Next
        Debug.Print "Fin de Traitement"
        Debug.Print
    End Select
End Sub

Function Set_Outlook_Folder(Mapi As Outlook.MAPIFolder, Target_Folder As Variant) As Outlook.MAPIFolder
    Dim Folder As Outlook.MAPIFolder
    On Error Resume Next
        For Each N In Split(Target_Folder, "\")
            Set Folder = Mapi.folders(N)
            If Folder Is Nothing Then Set Folder = Mapi.folders.Add(N)
            Set Mapi = Folder
            Set Folder = Nothing
        Next
    On Error GoTo 0
    Set Set_Outlook_Folder = Mapi
End Function

Function Set_WinDows_Folder(Target_Folder)
    Dim Folder
    For Each F In Split(Target_Folder, "\")
        Folder = IIf(Folder = "", "", Folder) & F & "\"
        If Dir(Folder, vbDirectory) = "" Then MkDir Folder
    Next
    Set_WinDows_Folder = Folder
End Function
 
Vote positif 0 Vote négatif
Bonjour Fanch55,

La pétanque a fait du bien, car la macro fonctionne. 😉

Vous êtes trop fort.

J'espère que vous avez gagné.

Voilà le résultat de la macro :



Si je peux encore abuser de votre temps, est-il possible que les fichiers contenus dans le lien zip soient renommés comme ci-dessous (Nom fournisseur_Numéro facture_ 01, 02, 03) et rangés directement dans le dossier Test ?:



Et le mail ne se déplace pas de la boîte de réception dans l'arborescence Outlook.

Voilà mes dernières remarques.

Encore un tout grand merci.

Bien à vous,
 
Vote positif 0 Vote négatif
DELATTE à dit:
Et le mail ne se déplace pas de la boîte de réception dans l'arborescence Outlook.
Cliquez pour agrandir...
Normal, l'option était désactivé en début de code :

DELATTE à dit:
Si je peux encore abuser de votre temps, est-il possible que les fichiers contenus dans le lien zip soient renommés comme ci-dessous (Nom fournisseur_Numéro facture_ 01, 02, 03) et rangés directement dans le dossier Test ?:
Cliquez pour agrandir...
Modif effectuée, si vous avez encore à déplacer le dossier cible, agissez sur la ligne :

Attention, les sous dossiers déjà créés existent toujours, à vous de les détruire

DELATTE à dit:
Si je peux encore abuser de votre temps, est-il possible que les fichiers contenus dans le lien zip soient renommés comme ci-dessous (Nom fournisseur_Numéro facture_ 01, 02, 03) et rangés directement dans le dossier Test ?:
Cliquez pour agrandir...
Le code ci-dessous le fait, il a fallu en revoir la cinématique ...

VB: 
Option Compare Text
Const Emetteur = "info@efact.public.lu"
Const Destinataire = "accounting"

Const Disque_Local = "S" ' nom du volume sur lequel stocker les fichiers dézippés
Const Move_Mail = True  ' mettre à True pour déplacer effectivement le mail

Sub Exec_Manuel() ' Lancement manuel à partir de la  boite de réception
Dim Bal As Outlook.Items, Mail As Outlook.MailItem
    On Error Resume Next
        Set Bal = GetNamespace("Mapi").Stores(Destinataire).GetDefaultFolder(olFolderInbox).Items
        If Bal Is Nothing Then
            MsgBox "Le destinataire " & Destinataire & vbLf _
                 & " n'existe probablement pas ...." & vbLf & vbLf _
                 & Err.Number & vbLf _
                 & Err.Description, vbCritical
        Else
            On Error GoTo 0
            Set Mail = Bal.Find("[SenderEmailAddress]=""" & Emetteur & """")
            If Not Mail Is Nothing Then Script_Delatte Mail
        End If
        
End Sub
Sub Tracer(Line)
    Doc_Folder = CreateObject("Shell.Application").NameSpace(&H5).self.Path
    Fic = FreeFile
    Open Doc_Folder & "\Trace_Body.txt" For Output As #Fic
        For Each Lin In Line
            Print #Fic, Lin
        Next
    Close #Fic
End Sub
Sub Script_Delatte(Mail As Outlook.MailItem)
Dim Folder   As Outlook.MAPIFolder
Dim An As String, Mois As String, Facture As String
Dim Target_Folder As Variant, Temp_Folder As Variant, Zip_File As Variant, Zip_Source As Variant, Line As Variant, Body As Variant
Dim Tampon() As Byte

Dim L As Integer, Requis As Integer

Select Case True
    Case Not Mail.ReceivedByName = Destinataire
    Case Not Mail.SenderEmailAddress = Emetteur
    Case Else
        Debug.Print "Incoming " & Mail.Subject _
                  & " from " & Mail.SenderEmailAddress _
                  & " to " & Mail.ReceivedByName
      
       ' on remplace d'abord les vbtab éventuels par par des "retour à la ligne"
       '             puis les doubles "retour à la ligne" par un seul
       ' et on éclate le mail en lignes en se basant sur le "retour à la ligne"
        Body = Mail.Body
        Body = Replace(Body, vbTab, vbCrLf)
        Body = Replace(Body, vbCrLf & vbCrLf, vbCrLf)
        Line = Split(Body, vbCrLf)
        ' Tracer Line
        For L = 0 To UBound(Line)
            Select Case True
            Case Trim(Line(L)) Like "N°*": Requis = Requis + 1
                Facture = Trim(Line(L + 1))
                Debug.Print , "Facture trouvée ( " & Facture & ") "
            
            Case Trim(Line(L)) Like "*.zip *": Requis = Requis + 1
                Z = Split(Line(L), "<")
                Zip_File = Trim(Z(0))
                Zip_Source = Trim(Replace(Z(1), ">", ""))
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
            
            Case Trim(Line(L)) Like "*émission de la facture*":
                W = Split(Trim(Line(L + 1)), "-")
                If UBound(W) < 2 Then
                    MsgBox "Date de facture incorrecte : " & Line(L + 1) & vbLf & "Abandon ....", vbCritical
                Else
                    Mois = W(1)
                      An = W(2)
                    Debug.Print , "Mois et An trouvés ( " & Mois & "/" & An & " )"
                    Requis = Requis + 1
                End If
            
            Case Trim(Line(L)) = "Émetteur :": Requis = Requis + 1
                Fournisseur = Trim(Line(L + 1))
                Debug.Print , "Fournisseur trouvé (" & Fournisseur & ")"
                
            Case Requis = 4
                Debug.Print "      Tous les requis sont acquis , traitement lancé"
                
                ' Construction de l'arborescence de stockage du mail s'il le faut
                Debug.Print , "Construction de l'arborescence outlook"
                Set Folder = Set_Outlook_Folder(GetNamespace("Mapi").folders(Mail.ReceivedByName), _
                        "Accounting\" & An & "\Fournisseurs\" & Mois & "." & An & "\" & Fournisseur)
                Mail.UnRead = False
                
                ' Déplacement ou non du Mail
                If Move_Mail Then
                    Debug.Print , "Archivage du mail dans " & Folder.FolderPath
                    Set Mail = Mail.Move(Folder)
                End If
                
                ' Enregistrement du fichier Zip
                Target_Folder = Set_WinDows_Folder( _
                     Disque_Local & ":\Administration\FOURNISSEURS\Fournisseurs " & An & "\Zip-UNZIP\test")
                Temp_Folder = CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2) & "\ZipOutlook"
                
                If Dir(Temp_Folder, vbDirectory) <> "" Then RmDir Temp_Folder
                MkDir Temp_Folder
                Zip_File = Temp_Folder & "\" & Zip_File
                Debug.Print , "Stockage du zip dans " & Temp_Folder
                With CreateObject("WinHttp.WinHttpRequest.5.1")
                    .Open "Get", Zip_Source, False
                    .Send
                    If .Status = 200 Then
                        Tampon = .responseBody
                        Fic = FreeFile
                        Open Zip_File For Binary Access Write As #Fic
                        Put #Fic, , Tampon
                        Close #Fic
                        Erase Tampon
                        ' dé-Zippage
                        Debug.Print , "Dézippage du zip dans " & Temp_Folder
                        With CreateObject("Shell.Application")
                             ' option 16 pour tout remplacer sans poser de question
                             .NameSpace(Temp_Folder).CopyHere .NameSpace(Zip_File).Items, 16
                        End With
                        Debug.Print , "Suppression du fichier Zip"
                        Kill Zip_File
                        Debug.Print , "Renommage des fichiers dézippés"
                        L = 1
                        Dim Oname As String, Nname As String, Ext As String
                        For Each File In CreateObject("Scripting.FileSystemObject").GetFolder(Temp_Folder).Files
                            Oname = File.Name
                            Ext = Mid(File.Name, InStrRev(File.Name, "."))
                            Nname = Target_Folder & "\" & Fournisseur & " " & Facture & "_" & L & Ext
                            If Dir(Nname) <> "" Then Kill Nname
                            Name File As Nname
                            Debug.Print , Oname & " ==> " & Nname
                            L = L + 1
                        Next
                    Else
                        MsgBox "Fichier Zip non trouvé sur le serveur" & vbLf & "Abandon ....", vbCritical
                    End If
                End With
                
                Exit For
            End Select
        Next
        Debug.Print "Fin de Traitement"
        Debug.Print
    End Select
End Sub

Function Set_Outlook_Folder(Mapi As Outlook.MAPIFolder, Target_Folder As Variant) As Outlook.MAPIFolder
    Dim Folder As Outlook.MAPIFolder
    On Error Resume Next
        For Each N In Split(Target_Folder, "\")
            Set Folder = Mapi.folders(N)
            If Folder Is Nothing Then Set Folder = Mapi.folders.Add(N)
            Set Mapi = Folder
            Set Folder = Nothing
        Next
    On Error GoTo 0
    Set Set_Outlook_Folder = Mapi
End Function

Function Set_WinDows_Folder(Target_Folder)
    Dim Folder
    For Each F In Split(Target_Folder, "\")
        Folder = IIf(Folder = "", "", Folder) & F & "\"
        If Dir(Folder, vbDirectory) = "" Then MkDir Folder
    Next
    Set_WinDows_Folder = Folder
End Function
 

Pièces jointes

  • 1734699214554.png
    6.7 KB · Affichages: 6
Vote positif 0 Vote négatif
Solution
Vous êtes trop fort.

Un tout grand merci.

Tout fonctionne parfaitement.

Je dois encore trouver le dossier créé dans Outlook car la barre de recherche trouve l'email mais je ne trouve pas le dossier créé.

Mais je vais trouver. 🙂

Je vous souhaite d'excellentes fêtes de fin d'année et à bientôt peut-être.

Cordialement,
 
Vote positif 0 Vote négatif
DELATTE à dit:
Regarde la pièce jointe 1209525


J'ai trouvé. 😉 La macro a re créée un dossier accounting sans tenir compte de la racine du compte email Accounting.
Cliquez pour agrandir...
C'est étonnant, mon outlook place bien le "Accounting" sous mon identifiant de boite .

Si vous désirez modifier le stockage outlook, c'est cette ligne qu'il vous faudra modifier :


A fin de test, j'ai retiré le "Accounting" en début, cela donne alors sans surprise :
 
Vote positif 0 Vote négatif
Bonne fêtes de fin d'année à vous aussi,
Si ma proposition a répondu à votre demande, n'oubliez pas de marquer le post #25 comme solution ( colonne de droite de celui-ci ), cela évitera à d'autres intervenants de s'escrimer sur une solution existante .... 😎
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

O
  • Question Question
Faire un historique d'email Outlook sous Excel + sauvegarde de pièces jointes
Réponses
2
Affichages
2 K
ozone083
O
M
[REF] Wiki 3 de MichelXld (Piloter d'autres applications depuis Excel)
Réponses
0
Affichages
80 K
MichelXld
M
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…