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

[DELATTE]

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,

 

[DELATTE]

Bonjour Fanch,

J'espère que les fêtes de Noël se sont bien passées.

A l'occasion, si vous avez un peu de temps, le dézippage et la sauvegarde ne fonctionne plus ce matin.

Auriez-vous une idée ?

Merci d'avance.

Bien à vous,

 

[fanch55]

Bonjour Fanch,

J'espère que les fêtes de Noël se sont bien passées.

A l'occasion, si vous avez un peu de temps, le dézippage et la sauvegarde ne fonctionne plus ce matin.

Auriez-vous une idée ?

Merci d'avance.

Bien à vous,

Bonjour, un Noël en demi teinte car beaucoup de défections pour cause de grippes....
Quels sont les messages dans le volet exécution ?

 

[DELATTE]

Voici les différents messages :

Tout à l'air en ordre mais le dézippage ne fonctionne plus alors que mardi dernier tout fonctionnait encore.

 

[fanch55]

Le volet n'a pas été entièrement capturé ou les messages se sont-ils brusquement arrêtés ?
Chez moi un traitement normal donne ceci :

 

[DELATTE]

Je viens de lancer le pas à pas, et l'erreur vient de là.

 

[DELATTE]

 

[fanch55]

Regarde la pièce jointe 1209946

Je viens de lancer le pas à pas, et l'erreur vient de là.

Pourriez-vous insérer la ligne de code :

Debug.print ,"Temp= " & Temp_Folder

dans le bloc:

' 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"
Debug.Print , "Temp= " & Temp_Folder
If Dir(Temp_Folder, vbDirectory) <> "" Then RmDir Temp_Folder
MkDir Temp_Folder

 

[DELATTE]

Merci pour votre patience.

Voici le résultat :

 

[fanch55]

OK, vous avez un nom d'utilisateur un peu "spécial" que n'arrive pas à résoudre la commande DIR .
On va prendre une autre méthode pour créer le dossier temporaire , je vous propose de ne remplacer que la Sub Script_Delatte

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), _
                         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")
                With CreateObject("Scripting.FileSystemObject")
                    Temp_Folder = .GetSpecialFolder(2) & "\ZipOutlook"
                    Debug.Print , "Temp= " & Temp_Folder
                    If .folderexists(Temp_Folder) Then .deletefolder (Temp_Folder)
                    .createFolder (Temp_Folder)
                End With
                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

 

[DELATTE]

Vous êtes un Dieu.
Encore un tout grand merci pour votre excellente analyse.
Profitez bien des derniers jours de 2024 avant d'attaquer la nouvelle année 2025.
A bientôt.