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

Créer une discussion
Répondre

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
fanch55
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 :
1734698939198.png

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 :
1734699121730.png

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
Cela devrait le faire :
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, 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 = Replace(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 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
                            Ext = Mid(File.Name, InStrRev(File.Name, "."))
                            Select Case True
                            Case LFiles = "":  LFiles = File.Name
                            Case Ext = ".xml": LFiles = LFiles & "|" & File.Name
                            Case Else:         LFiles = File.Name & "|" & LFiles
                            End Select
                        Next
                        For Each File In Split(LFiles, "|")
                            Ext = Mid(File, InStrRev(File, "."))
                            Nname = Target_Folder & Fournisseur & " " & Facture & "_" & L & Ext
                            If Dir(Nname) <> "" Then Kill Nname
                            Name Temp_Folder & "\" & File As Nname
                            Debug.Print , File & " ==> " & 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
 
Vote positif 0 Vote négatif
Bonjour Fanch,

J'ai à nouveau un problème de caractère spécial non reconnu pour un fournisseur. L'accent aigu arrive comme ceci dans les emails automatiques.

Est-il envisageable de compléter la macro pour remplacer le caractère ci-dessous par é :

A.B.S.C. Soci�t� anonyme

En cherchant sur Internet, j'ai trouvé ces codes si cela peut vous aider :

outils-javascript.aliasdmc.fr

Le bon encodage pour les caractères accentués et spéciaux : Outils-javascript.aliasdmc.fr

Générateur de correspondance d'encodage des caractères pour les CSS et Javascript et HTML afin d'éviter des problème d'affichage des caractères accentués et des caractères spéciaux. Liste des correspondances des caractères encodés spéciaux et accentués classés par caractère pour les CSS et...
outils-javascript.aliasdmc.fr

1737019181457.png


Merci d'avance.

Excellente journée à vous,
 
Vote positif 0 Vote négatif
En fait, l'encodage &HFFFD représente ce que substitue Office pour tout caractère mal formé .
On ne peut pas déterminer la valeur exacte qui a été remplacée
( en ce cas c'est le é car nous ne sommes pas des IA, mais ce pourrait être autre chose , par exemple Établissement)
•​
Émetteur :A.B.S.C. Soci�t� anonyme
•​
Identifiant Peppol de l’émetteur :LU18534244
•​
Date d’émission de la facture :31-12-2024
•​
Date de réception effective :10-01-2025
•​
Destinataire :Philharmonie Luxembourg & Luxembourg Philharmonic �tablissement public Salle de Concert Gde Duchesse Jos�phine
•​
Identifiant Peppol du destinataire :LU19620953
Cliquez pour agrandir...
Il vaut mieux demander à l'émetteur de corriger de son côté et de vous envoyer les bons caractères attendus, que ce soit dans le corps du mail et/ou dans les pièces jointes ( je vous invite à examiner les fichiers Pdf ) ....
On voit nettement dans le tableau ci-dessus que le logiciel qui a rempli le formulaire du mail ( où les parties fixes sont bien encodés ) ne s'est pas du tout préoccupé de l'encodage lors de la saisie ( copier/coller ? ).....

En attendant, pour ne pas vous bloquer, vous pouvez "effacer" ces caractères dans la sub Script_Delatte :
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))
            Select Case True
            Case Trim(Ligne(L)) Like "N°*": Requis = Requis + 1
                Facture = Replace(Trim(Ligne(L + 1)), "/", "_")
                Debug.Print , "Facture trouvée ( " & Facture & ") "
           
            Case Trim(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 Trim(Ligne(L)) Like "*émission de la facture*":
                W = Split(Trim(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 Trim(Ligne(L)) = "Émetteur :": Requis = Requis + 1
                fournisseur = Trim(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
                            Ext = Mid(File.Name, InStrRev(File.Name, "."))
                            Select Case True
                            Case LFiles = "":  LFiles = File.Name
                            Case Ext = ".xml": LFiles = LFiles & "|" & File.Name
                            Case Else:         LFiles = File.Name & "|" & LFiles
                            End Select
                        Next
                        For Each File In Split(LFiles, "|")
                            Ext = Mid(File, InStrRev(File, "."))
                            Nname = Target_Folder & fournisseur & " " & Facture & "_" & L & Ext
                            If Dir(Nname) <> "" Then Kill Nname
                            Name Temp_Folder & "\" & File As Nname
                            Debug.Print , File & " ==> " & 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
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour Fanch,

J'espère que vous allez bien.

Afin d'affiner un peu plus votre merveilleuse macro, j'aimerais ajouter deux lignes de commande :

1/ Une première qui vérifie que les fichiers ont bien été renommés et ransférés après le dézippage en vérifiant que le dossier temporaire "C:\Users\jp.delatte\AppData\Local\Temp\ZipOutlook" est bien vide
2/Une autre ligne qui permettrait de supprimer les fichiers XML une fois la macro terminée (cette ligne est temporaire en attendant la réelle utilisation des fichiers xml.

Merci d'avance.

Excellente journée à vous,
 
Vote positif 0 Vote négatif
DELATTE à dit:
1/ Une première qui vérifie que les fichiers ont bien été renommés et ransférés après le dézippage en vérifiant que le dossier temporaire "C:\Users\jp.delatte\AppData\Local\Temp\ZipOutlook" est bien vide
Cliquez pour agrandir...
Avant de stocker le fichier Zip reçu, le dossier Temp\ZipOutlook est systématiquement recréé, quoiqu'il puisse encore contenir .
Il est fortement improbable à 99% que les fichiers n'aient pas pu être transférés sinon face à un problème d'espace disque .
En ce cas, la macro se plantera aussitôt .
Ce qu'on peut faire éventuellement, c'est supprimer le dossier ZipOutlook en fin de transfert .

DELATTE à dit:
2/Une autre ligne qui permettrait de supprimer les fichiers XML une fois la macro terminée (cette ligne est temporaire en attendant la réelle utilisation des fichiers xml.
Cliquez pour agrandir...
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
Ext = Mid(File.Name, InStrRev(File.Name, "."))
Select Case True
Case LFiles = "": LFiles = File.Name
Case Ext = ".xml": LFiles = LFiles & "|" & File.Name
Case Else: LFiles = File.Name & "|" & LFiles
End Select
Next
For Each File In Split(LFiles, "|")
Ext = Mid(File, InStrRev(File, "."))
Nname = Target_Folder & fournisseur & " " & Facture & "_" & L & Ext
If Dir(Nname) <> "" Then Kill Nname
Name Temp_Folder & "\" & File As Nname
Debug.Print , , File & " ==> " & Nname
L = L + 1
Next
Debug.Print , "suppression des fichiers Xml"
Kill Target_Folder & "*.xml"
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
pour re-conserver les fichers Xml, commenter les deux lignes ci-dessous :
Code: 
          ......
          Debug.Print , "suppression des fichiers Xml"
          Kill Target_Folder & "*.xml"
          ......
 
Vote positif 0 Vote négatif
Pour supprimer les Xml, c'est parfait.

Concernant l'erreur de renommage, la macro ignore la procédure de renommage des fichiers dès que l'un des fichiers dans le zip ne contient pas d'extension :
1738159107323.png

Ce genre de fichier est toujours un fichier pdf. Peut-être est-il possible de rajouter l'extension ".pdf" pour les fichiers sans extensions.

Merci encore.
 
Vote positif 0 Vote négatif
DELATTE à dit:
Pour supprimer les Xml, c'est parfait.

Concernant l'erreur de renommage, la macro ignore la procédure de renommage des fichiers dès que l'un des fichiers dans le zip ne contient pas d'extension :
Regarde la pièce jointe 1211933
Ce genre de fichier est toujours un fichier pdf. Peut-être est-il possible de rajouter l'extension ".pdf" pour les fichiers sans extensions.

Merci encore.
Cliquez pour agrandir...
Si vous voulez palier à tous les manques de rigueur des zip reçus : insérez la ligne suivante :
Enrichi (BBcode): 
                        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 Else:         LFiles = File.Name & "|" & LFiles
                            End Select
                        Next
                        For Each File In Split(LFiles, "|")
 
Vote positif 0 Vote négatif
fanch55 à dit:
Si vous voulez palier à tous les manques de rigueur des zip reçus : insérez la ligne suivante :
Enrichi (BBcode): 
                        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 Else:         LFiles = File.Name & "|" & LFiles
                            End Select
                        Next
                        For Each File In Split(LFiles, "|")
Cliquez pour agrandir...
Parfait. Excellente fin de journée.
 
Vote positif 0 Vote négatif
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
Retour