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

Debug.print ,"Temp= " & Temp_Folder

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