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

DELATTE · 4 Décembre 2024

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 · 25 Avril 2025

fanch55 à dit:

Bonjour,
J'ai eu un peu de retard à l'allumage car il m'a fallu me replonger dans le contexte,
Le code suivant devrait répondre à votre demande :

VB:

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, Ligne 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 = Replace(Mail.Body, ChrW(&HFFFD), "") ' pour ceux qui envoit mal les accents
        Body = Replace(Body, vbTab, vbCrLf)
        Body = Replace(Body, vbCrLf & vbCrLf, vbCrLf)
        Ligne = Split(Body, vbCrLf)
        ' Tracer Ligne
        For L = 0 To UBound(Ligne)
       
            Ligne(L) = Trim(Ligne(L))
            If L < UBound(Ligne) Then Ligne(L + 1) = Trim(Ligne(L + 1))
           
            Select Case True
            Case Ligne(L) Like "N°*": Requis = Requis + 1
                Facture = Replace(Ligne(L + 1), "/", "_")
                Debug.Print , "Facture trouvée ( " & Facture & ") "
           
            Case Ligne(L) Like "*.zip *": Requis = Requis + 1
                Z = Split(Ligne(L), "<")
                Zip_File = Trim(Z(0))
                Zip_Source = Trim(Replace(Z(1), ">", ""))
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
           
            Case Ligne(L) Like "*émission de la facture*":
                W = Split(Ligne(L + 1), "-")
                If UBound(W) < 2 Then
                    MsgBox "Date de facture incorrecte : " & Ligne(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 Ligne(L) = "Émetteur :": Requis = Requis + 1
                fournisseur = Ligne(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 LFiles As Variant, Nname As String, Ext As String
                        ' les Xml seront en fin de liste de fichiers
                        LFiles = ""
                        For Each File In CreateObject("Scripting.FileSystemObject").GetFolder(Temp_Folder).Files
                            If InStrRev(File.Name, ".") = 0 Then File.Name = File.Name & ".pdf"
                            Ext = Mid(File.Name, InStrRev(File.Name, "."))
                            Select Case True
                            Case LFiles = "":  LFiles = File.Name
                            Case Ext = ".xml": LFiles = LFiles & "|" & File.Name
                            Case File.Name Like "*Données clés extraites*": First_Name = File.Name
                            Case Else:         LFiles = File.Name & "|" & LFiles
                            End Select
                        Next
                        If First_Name <> "" Then If Not InStr(LFiles, First_Name) Then LFiles = First_Name & "|" & LFiles
                        For Each File In Split(LFiles, "|")
                            Ext = Mid(File, InStrRev(File, "."))
                            Nname = Target_Folder & fournisseur & " " & Facture & "_" & L & Ext
                            If Dir(Nname) <> "" Then Kill Nname
                            Select Case Ext
                            Case ".pdf"
                                Name Temp_Folder & "\" & File As Nname
                                Debug.Print , , File & " ==> " & Nname
                                L = L + 1
                            Case Else
                                Kill Temp_Folder & "\" & File
                                Debug.Print , , File & " !!! supprimé"
                            End Select
                        Next
                        Debug.Print , "suppression de " & Temp_Folder
                        RmDir Temp_Folder
                    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

Merci pour votre rapidité, mais le fichier contenant les termes "Données clés extraites de la facture" ne se nomme pas en numéro 1.
Ce n'est pas si grave. Ne perdez pas votre temps. 😉

DELATTE · 25 Avril 2025

DELATTE à dit:
Merci pour votre rapidité, mais le fichier contenant les termes "Données clés extraites de la facture" ne se nomme pas en numéro 1.
Ce n'est pas si grave. Ne perdez pas votre temps. 😉

Ce nom de fichier est une partie du nom danbs un fichier au moment du dézippage.

fanch55 · 25 Avril 2025

Je ne comprend pas, cela fonctionne comme attendu chez moi :
Il faut dire que je travaille toujours sur le message que vous m'aviez envoyé en décembre 2024
Pourriez-vous transmettre le Mail posant problème vers test.vba.fanch55@free.fr ?

fanch55 · 26 Avril 2025

Ayé, j'ai reproduit le phénomène avec le premier message (Muller). En analyse ....

fanch55 · 26 Avril 2025

Ok, renommage normalement résolu :

VB:

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, Ligne 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 = Replace(Mail.Body, ChrW(&HFFFD), "") ' pour ceux qui envoient mal les accents
        Body = Replace(Body, vbTab, vbCrLf)
        Body = Replace(Body, vbCrLf & vbCrLf, vbCrLf)
        Ligne = Split(Body, vbCrLf)
        ' Tracer Ligne
        For L = 0 To UBound(Ligne)
        
            Ligne(L) = Trim(Ligne(L))
            If L < UBound(Ligne) Then Ligne(L + 1) = Trim(Ligne(L + 1))
            
            Select Case True
            Case Ligne(L) Like "N°*": Requis = Requis + 1
                Facture = Replace(Ligne(L + 1), "/", "_")
                Debug.Print , "Facture trouvée ( " & Facture & ") "
            
            Case Ligne(L) Like "*.zip *": Requis = Requis + 1
                Z = Split(Ligne(L), "<")
                Zip_File = Trim(Z(0))
                Zip_Source = Trim(Replace(Z(1), ">", ""))
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
            
            Case Ligne(L) Like "*émission de la facture*":
                W = Split(Ligne(L + 1), "-")
                If UBound(W) < 2 Then
                    MsgBox "Date de facture incorrecte : " & Ligne(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 Ligne(L) = "Émetteur :": Requis = Requis + 1
                fournisseur = Ligne(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 LFiles As Variant, Nname As String, Ext As String
                        ' les Xml seront en fin de liste de fichiers
                        LFiles = ""
                        For Each File In CreateObject("Scripting.FileSystemObject").GetFolder(Temp_Folder).Files
                            If InStrRev(File.Name, ".") = 0 Then File.Name = File.Name & ".pdf"
                            Ext = Mid(File.Name, InStrRev(File.Name, "."))
                            Select Case True
                            Case File.Name Like "*Données clés extraites*":
                                               First_Name = File.Name
                            Case LFiles = "":  LFiles = File.Name
                            Case Ext = ".xml": LFiles = LFiles & "|" & File.Name
                            Case Else:         LFiles = File.Name & "|" & LFiles
                            End Select
                        Next
                        If First_Name <> "" Then  LFiles = First_Name & "|" & LFiles
                        For Each File In Split(LFiles, "|")
                            Ext = Mid(File, InStrRev(File, "."))
                            Nname = Target_Folder & fournisseur & " " & Facture & "_" & L & Ext
                            If Dir(Nname) <> "" Then Kill Nname
                            Select Case Ext
                            Case ".pdf"
                                Name Temp_Folder & "\" & File As Nname
                                Debug.Print , , File & " ==> " & Nname
                                L = L + 1
                            Case Else
                                Kill Temp_Folder & "\" & File
                                Debug.Print , , File & " !!! supprimé"
                            End Select
                        Next
                        Debug.Print , "suppression de " & Temp_Folder
                        RmDir Temp_Folder
                    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 · 27 Avril 2025

fanch55 à dit:

Ok, renommage normalement résolu :

VB:

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, Ligne 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 = Replace(Mail.Body, ChrW(&HFFFD), "") ' pour ceux qui envoient mal les accents
        Body = Replace(Body, vbTab, vbCrLf)
        Body = Replace(Body, vbCrLf & vbCrLf, vbCrLf)
        Ligne = Split(Body, vbCrLf)
        ' Tracer Ligne
        For L = 0 To UBound(Ligne)
       
            Ligne(L) = Trim(Ligne(L))
            If L < UBound(Ligne) Then Ligne(L + 1) = Trim(Ligne(L + 1))
           
            Select Case True
            Case Ligne(L) Like "N°*": Requis = Requis + 1
                Facture = Replace(Ligne(L + 1), "/", "_")
                Debug.Print , "Facture trouvée ( " & Facture & ") "
           
            Case Ligne(L) Like "*.zip *": Requis = Requis + 1
                Z = Split(Ligne(L), "<")
                Zip_File = Trim(Z(0))
                Zip_Source = Trim(Replace(Z(1), ">", ""))
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
           
            Case Ligne(L) Like "*émission de la facture*":
                W = Split(Ligne(L + 1), "-")
                If UBound(W) < 2 Then
                    MsgBox "Date de facture incorrecte : " & Ligne(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 Ligne(L) = "Émetteur :": Requis = Requis + 1
                fournisseur = Ligne(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 LFiles As Variant, Nname As String, Ext As String
                        ' les Xml seront en fin de liste de fichiers
                        LFiles = ""
                        For Each File In CreateObject("Scripting.FileSystemObject").GetFolder(Temp_Folder).Files
                            If InStrRev(File.Name, ".") = 0 Then File.Name = File.Name & ".pdf"
                            Ext = Mid(File.Name, InStrRev(File.Name, "."))
                            Select Case True
                            Case File.Name Like "*Données clés extraites*":
                                               First_Name = File.Name
                            Case LFiles = "":  LFiles = File.Name
                            Case Ext = ".xml": LFiles = LFiles & "|" & File.Name
                            Case Else:         LFiles = File.Name & "|" & LFiles
                            End Select
                        Next
                        If First_Name <> "" Then  LFiles = First_Name & "|" & LFiles
                        For Each File In Split(LFiles, "|")
                            Ext = Mid(File, InStrRev(File, "."))
                            Nname = Target_Folder & fournisseur & " " & Facture & "_" & L & Ext
                            If Dir(Nname) <> "" Then Kill Nname
                            Select Case Ext
                            Case ".pdf"
                                Name Temp_Folder & "\" & File As Nname
                                Debug.Print , , File & " ==> " & Nname
                                L = L + 1
                            Case Else
                                Kill Temp_Folder & "\" & File
                                Debug.Print , , File & " !!! supprimé"
                            End Select
                        Next
                        Debug.Print , "suppression de " & Temp_Folder
                        RmDir Temp_Folder
                    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

Parfait. Encore un grand merci et bon dimanche. Bien à vous,

DELATTE · 20 Mai 2025

Bonjour Fanch,

J'aurais encore une petite modification à appliquer. J'ai essayé de trouvé par moi-même mais celà ne fonctionne pas.
Dans la ligne suivante : If InStrRev(File.Name, ".") = 0 Then File.Name = File.Name & ".pdf", les fichiers sans extensions sont renommés avec l'extension .PDF et pas en .pdf. L'extension PDF en majuscule n'est pas reconnue dans une autre macro. Y a t'il un moyen de forcer la minuscule ?
Merci d'avance. Excellente journée à vous,

fanch55 · 20 Mai 2025

Bonsoir, pouvez-vous me fournir un message exemple ?

DELATTE · 21 Mai 2025

fanch55 à dit:
Bonsoir, pouvez-vous me fournir un message exemple ?

Bonjour Fanch, voilà l'exemple avec un fichier sans extension. Lorqu'il est renommé, il est en .PDF et lorsque je lance votre autre macro d'impression PDF, les fichiers avec extension en majuscule de sont pas pris en compte. Lorque je change la casse, tout fonctionne. 😉

fanch55 · 21 Mai 2025

Bonjour,
Le PDF(majuscule) se trouve déjà dans le fichier Zip reçu .

Le problème provient du manque de rigueur de l'émetteur qui a déjà nommé le fichier du zip en .PDF (par ailleurs: pourquoi celui-ci et pas les autres ? ).
Le code d'extraction reconnait bien un fichier .PDF comme un fichier .pdf et le laisse donc tel quel .
S'il faut forcer la conversion de l'extension en "minuscule" , il faut corriger la ligne de code ci-dessous ( déjà corrigée içi )

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, Ligne 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 = Replace(Mail.Body, ChrW(&HFFFD), "") ' pour ceux qui envoient mal les accents
Body = Replace(Body, vbTab, vbCrLf)
Body = Replace(Body, vbCrLf & vbCrLf, vbCrLf)
Ligne = Split(Body, vbCrLf)
' Tracer Ligne
For L = 0 To UBound(Ligne)

Ligne(L) = Trim(Ligne(L))
If L < UBound(Ligne) Then Ligne(L + 1) = Trim(Ligne(L + 1))

Select Case True
Case Ligne(L) Like "N°*": Requis = Requis + 1
Facture = Replace(Ligne(L + 1), "/", "_")
Debug.Print , "Facture trouvée ( " & Facture & ") "

Case Ligne(L) Like "*.zip *": Requis = Requis + 1
Z = Split(Ligne(L), "<")
Zip_File = Trim(Z(0))
Zip_Source = Trim(Replace(Z(1), ">", ""))
Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"

Case Ligne(L) Like "*émission de la facture*":
W = Split(Ligne(L + 1), "-")
If UBound(W) < 2 Then
MsgBox "Date de facture incorrecte : " & Ligne(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 Ligne(L) = "Émetteur :": Requis = Requis + 1
fournisseur = Ligne(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 LFiles As Variant, Nname As String, Ext As String
' les Xml seront en fin de liste de fichiers
LFiles = ""
For Each File In CreateObject("Scripting.FileSystemObject").GetFolder(Temp_Folder).Files
If InStrRev(File.Name, ".") = 0 Then File.Name = File.Name & ".pdf"
Ext = Mid(File.Name, InStrRev(File.Name, "."))
Select Case True
Case File.Name Like "*Données clés extraites*":
First_Name = File.Name
Case LFiles = "": LFiles = File.Name
Case Ext = ".xml": LFiles = LFiles & "|" & File.Name
Case Else: LFiles = File.Name & "|" & LFiles
End Select
Next
If First_Name <> "" Then LFiles = First_Name & "|" & LFiles
For Each File In Split(LFiles, "|")
Ext = LCase(Mid(File, InStrRev(File, ".")))
Nname = Target_Folder & fournisseur & " " & Facture & "_" & L & Ext
If Dir(Nname) <> "" Then Kill Nname
Select Case Ext
Case ".pdf"
Name Temp_Folder & "\" & File As Nname
Debug.Print , , File & " ==> " & Nname
L = L + 1
Case Else
Kill Temp_Folder & "\" & File
Debug.Print , , File & " !!! supprimé"
End Select
Next
Debug.Print , "suppression de " & Temp_Folder
RmDir Temp_Folder
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 · 21 Mai 2025

Encore un grand merci comme toujours. Excellente journée. Bien à vous,

DELATTE · 6 Août 2025

Bonjour Fanch,

J'espère que tout va bien pour vous.

Je voulais savoir si vous auriez une idée afin d'ajouter une ligne dans la macro qui permettrait d'attendre que 100% de cette macro soit exécutée avant de recommencer le script. (ou un message qui signale d'attendre)

Comme cette macro se lance manuellement, j'ai remarqué que si on clique trop rapidement sur celle-ci, elle se relance pour le traitement de l'email suivant sans avoir fini de renommer le précédent.

Merci d'avance.

Bien à vous,

fanch55 · 6 Août 2025

Bonjour,
pour ceux qui "bégaye" du doigt (😉) ou afficionado du double-clic
Attention: correction du 07/08 à 08:30, on donne 2 minutes à la première exécution pour se terminer

VB:

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, Ligne As Variant, Body As Variant
Dim Tampon() As Byte
Dim Flag As Integer

Dim L As Integer, Requis As Integer

If Mail.FlagRequest = "" Then Flag = 2 Else Flag = DateDiff("n", Mail.FlagRequest, Now)
Select Case True
    Case Flag < 2 ' on laisse un écart de 2 minutes
        MsgBox "Le traitement a déja été lancé le" & vbLf _
             & Replace(Mail.FlagRequest, " ", " à "), vbCritical, "Mail déjà reservé"
    Case Not Mail.ReceivedByName = Destinataire
    Case Not Mail.SenderEmailAddress = Emetteur
    Case Else
        Mail.FlagRequest = Now
        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 = Replace(Mail.Body, ChrW(&HFFFD), "") ' pour ceux qui envoient mal les accents
        Body = Replace(Body, vbTab, vbCrLf)
        Body = Replace(Body, vbCrLf & vbCrLf, vbCrLf)
        Ligne = Split(Body, vbCrLf)
        ' Tracer Ligne
        For L = 0 To UBound(Ligne)
      
            Ligne(L) = Trim(Ligne(L))
            If L < UBound(Ligne) Then Ligne(L + 1) = Trim(Ligne(L + 1))
          
            Select Case True
            Case Ligne(L) Like "N°*": Requis = Requis + 1
                Facture = Replace(Ligne(L + 1), "/", "_")
                Debug.Print , "Facture trouvée ( " & Facture & ") "
          
            Case Ligne(L) Like "*.zip *": Requis = Requis + 1
                Z = Split(Ligne(L), "<")
                Zip_File = Trim(Z(0))
                Zip_Source = Trim(Replace(Z(1), ">", ""))
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
          
            Case Ligne(L) Like "*émission de la facture*":
                W = Split(Ligne(L + 1), "-")
                If UBound(W) < 2 Then
                    MsgBox "Date de facture incorrecte : " & Ligne(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 Ligne(L) = "Émetteur :": Requis = Requis + 1
                fournisseur = Ligne(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 LFiles As Variant, Nname As String, Ext As String
                        ' les Xml seront en fin de liste de fichiers
                        LFiles = ""
                        For Each File In CreateObject("Scripting.FileSystemObject").GetFolder(Temp_Folder).Files
                            If InStrRev(File.Name, ".") = 0 Then File.Name = File.Name & ".pdf"
                            Ext = Mid(File.Name, InStrRev(File.Name, "."))
                            Select Case True
                            Case File.Name Like "*Données clés extraites*":
                                               First_Name = File.Name
                            Case LFiles = "":  LFiles = File.Name
                            Case Ext = ".xml": LFiles = LFiles & "|" & File.Name
                            Case Else:         LFiles = File.Name & "|" & LFiles
                            End Select
                        Next
                        If First_Name <> "" Then LFiles = First_Name & "|" & LFiles
                        For Each File In Split(LFiles, "|")
                            Ext = LCase(Mid(File, InStrRev(File, ".")))
                            Nname = Target_Folder & fournisseur & " " & Facture & "_" & L & Ext
                            If Dir(Nname) <> "" Then Kill Nname
                            Select Case Ext
                            Case ".pdf"
                                Name Temp_Folder & "\" & File As Nname
                                Debug.Print , , File & " ==> " & Nname
                                L = L + 1
                            Case Else
                                Kill Temp_Folder & "\" & File
                                Debug.Print , , File & " !!! supprimé"
                            End Select
                        Next
                        Debug.Print , "suppression de " & Temp_Folder
                        RmDir Temp_Folder
                    Else
                        MsgBox "Fichier Zip non trouvé sur le serveur" & vbLf & "Abandon ....", vbCritical
                    End If
                End With
               
                Exit For
            End Select
        Next
        Mail.ClearTaskFlag
        Debug.Print , "Fin de Traitement"
        Debug.Print
    End Select
End Sub

DELATTE · 7 Août 2025

Bonjour Fanch,

Merci beaucoup pour ces mises à jour. Je viens de tester. Tout fonctionne.

Excellente journée à vous,

Cordialement,

Effectuez une recherche sur Excel Downloads...

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

DELATTE

XLDnaute Junior

fanch55

DELATTE

XLDnaute Junior

DELATTE

XLDnaute Junior

fanch55

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Junior

DELATTE

XLDnaute Junior

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Junior

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Junior

DELATTE

XLDnaute Junior

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Junior

Nous accordons de l'importance à votre vie privée