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,

fanch55 · 20 Décembre 2024

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

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 ?:

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...

fanch55 · 5 Décembre 2024

Bonsoir,
Vous allez devoir afficher l'onglet développeur dans Outlook et entrer dans le Visual Basic .

Dans le volet gauche, dans le module ThisOutlookSession :

entrez le code ci-dessous :

VB:

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
    Dim Entry As Variant
    For Each Entry In Split(EntryIDCollection, ",")
        Script_Delatte Application.Session.GetItemFromID(Entry)
    Next
End Sub

Ce code sera exécuté pour chaque mail arrivant dans la boite de réception.

Insérez un nouveau module

Entrez-y le code ci-dessous :
( vérifiez auparavant ce qui concerne l'émetteur et le destinataire
ainsi que le Target_Path et le Target_Folder qui me semblent incomplets coté dézippage )

VB:

Sub Exec_Manuel()
'    pour lancer le script manuellement,
'    le mail doit être dans le dossier réceptions et affiché
    Script_Delatte ActiveInspector.CurrentItem
End Sub
Sub Script_Delatte(Mail As Outlook.MailItem)
Dim Folder   As MAPIFolder
Dim An As String, Mois As String, Facture As String
Dim Target_Folder As Variant, Target_Path As Variant, Zip_File As Variant

Select Case True
    Case Not Mail.ReceivedByName Like "test.vba.fanch55*" ' Destinataire
    Case Not Mail.SenderName Like "Fanch*"                ' Emetteur
    Case Else
        Debug.Print "Incoming " & Mail.Subject _
                  & " from " & Mail.SenderName _
                  & " to " & Mail.ReceivedByName

        For Each Line In Split(Mail.Body, vbCrLf)
            If Trim(Line) Like "*.zip" Then
'               Construction de l'arborescence s'il le faut
                An = Left(Line, 4): Mois = Mid(Line, 5, 2)
                Facture = Split(Split(Line, "_")(2), ".")(0)
                Set Folder = GetNamespace("Mapi").Folders(Mail.ReceivedByName)
                Set Folder = SetFolder(Folder, "Accounting")
                Set Folder = SetFolder(Folder, An)
                Set Folder = SetFolder(Folder, "Fournisseurs")
                Set Folder = SetFolder(Folder, Mois & "." & An)
                Set Folder = SetFolder(Folder, Mail.SenderName)
'               -------------------------------------------------------------------------------------------------
'               Décommenter les 2 lignes suivantes pour déplacer réellement le mail
'                Mail.UnRead = False
'                Mail.Move Folder
'               -------------------------------------------------------------------------------------------------
                With Mail.Attachments.Item(1) ' Fichier joint
                   ' enregistrement du fichier Zip
                    Target_Path = "F:\Delatte\" & Mail.SenderName & "_" & Facture
                    If Dir(Target_Path, vbDirectory) = "" Then MkDir Target_Path
                    Zip_File = Target_Path & "\" & .FileName
                    .SaveAsFile Zip_File
                  
                   ' dé-Zippage
                    Target_Folder = Target_Path & "\" & Split(.FileName, ".")(0) ' nom du dossier cible
                    If Dir(Target_Folder, vbDirectory) = "" Then MkDir Target_Folder
                    With CreateObject("Shell.Application")
                        .NameSpace(Target_Folder).CopyHere .NameSpace(Zip_File).Items, 16 ' 16 pour tout remplacer
                    End With
                    Kill Zip_File
                End With
            End If
        Next
    End Select
End Sub
Function SetFolder(F As MAPIFolder, N) As MAPIFolder
    On Error Resume Next
        Set SetFolder = F.Folders(N)
        If SetFolder Is Nothing Then Set SetFolder = F.Folders.Add(N)
    On Error GoTo 0
End Function

Testé avec succès avec le mail ci-dessous:

Dossiers archive de Outlook :

DELATTE · 6 Décembre 2024

Bonjour Fanch55,

Je vous remercie pour votre excellente aide.

Si je peux encore vous apporter une petite précision afin de mettre à jour la macro :

L'ensemble de ces factures automatiques proviennent toutes de l'expéditeur : info@efact.public.lu qui est une plateforme automatique.

L'indication du nom du fournisseur se situe dans le corps du mail en face de Emetteur.

Si vous avez encore un peu de temps à me consacrer, pourriez-vous mettre la VBA à jour ?

Encore un tout grand merci.

Etant moi-même amateur des performances des macros, j'admire toujours leurs puissances d'automatisation.

Excellente journée à vous,

Cordialement,

DELATTE · 6 Décembre 2024

Je viens d'essayer ceci mais rien ne se passe. A savoir que j'ai deux boîtes de réception dans Outlook.

fanch55 · 6 Décembre 2024

Bonsoir, désolé, j'étais absent dans la journée .
Voici le code adapté à votre demande :

VB:

Option Compare Text

Sub Exec_Manuel()
'    pour lancer le script manuellement,
'    le mail doit être dans le dossier réception et affiché
    Script_Delatte ActiveInspector.CurrentItem
End Sub

Sub Script_Delatte(Mail As Outlook.MailItem)
Dim Folder   As MAPIFolder
Dim An As String, Mois As String, Facture As String
Dim Target_Folder As Variant, Zip_File As Variant, Line As Variant
Dim L As Integer, Requis As Integer

Const Emetteur = "info@efact.public.lu"
Const Destinataire = "accounting@societe.lu"

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))
           
            Case Trim(Line(L)) Like "*émission de la facture*": Requis = Requis + 1
                W = Split(Trim(Line(L + 1)), "-")
                Mois = W(1)
                An = W(2)
           
            Case Trim(Line(L)) = "Émetteur :": Requis = Requis + 1
                Fournisseur = Trim(Line(L + 1))
               
            Case Requis = 3
'               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

'               -------------------------------------------------------------------------------------------------
'               Décommenter la ligne suivante pour déplacer réellement le mail
                Set Mail = Mail.Move(Folder)
'               -------------------------------------------------------------------------------------------------
                With Mail.Attachments.Item(1) ' Fichier joint
                   ' enregistrement du fichier Zip
                    Target_Folder = Set_WinDows_Folder("S:\Administration\FOURNISSEURS\Fournisseurs " & An & "\Zip-UNZIP\test\" & Fournisseur & "\" & Facture)
                    Zip_File = Target_Folder & .FileName
                    .SaveAsFile Zip_File
                   
                   ' 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
                    Kill Zip_File
                End With
                Exit For
            End Select
        Next
    End Select
End Sub

Function Set_Outlook_Folder(Mapi As MAPIFolder, Target_Folder As Variant) As MAPIFolder
    Dim Folder As 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

fanch55 · 6 Décembre 2024

DELATTE à dit:
Je viens d'essayer ceci mais rien ne se passe. A savoir que j'ai deux boîtes de réception dans Outlook.

Pas de problème avec des boites multiples dans Outlook, moi-même, j'en ai 5 .
Si le mail semble figé dans la boite de réception, sélectionnez/affichez-le et exécutez la sub Exec_Manuel en mode pas à pas, cela vous donnera une idée de l'endroit où cela dérive ...

Affichez et regardez également le Volet Exécution, il devrait y avoir une trace si le mail est éligible .

fanch55 · 7 Décembre 2024

Correction du code pour ne pas avoir à sélectionner et afficher le mail avant de lancer l'exécution manuelle :

VB:

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

Sub Exec_Manuel() ' Lancement manuel à partir de la  boite de réception
Dim Bal As Items, Mail As MailItem
    Set Bal = GetNamespace("Mapi").folders(Destinataire).folders("Boîte de réception").Items
    Set Mail = Bal.Find("[SenderEmailAddress]=""" & Emetteur & """")
    If Not Mail Is Nothing Then Script_Delatte Mail
End Sub

Sub Script_Delatte(Mail As MailItem)
Dim Folder   As MAPIFolder
Dim An As String, Mois As String, Facture As String
Dim Target_Folder As Variant, Zip_File As Variant, Line As Variant
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))
           
            Case Trim(Line(L)) Like "*émission de la facture*": Requis = Requis + 1
                W = Split(Trim(Line(L + 1)), "-")
                Mois = W(1)
                An = W(2)
           
            Case Trim(Line(L)) = "Émetteur :": Requis = Requis + 1
                Fournisseur = Trim(Line(L + 1))
               
            Case Requis = 3
'               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
'               -------------------------------------------------------------------------------------------------
'               Décommenter la ligne suivante pour déplacer réellement le mail
                Set Mail = Mail.Move(Folder)
'               -------------------------------------------------------------------------------------------------
                With Mail.Attachments.Item(1) ' Fichier joint
                   ' enregistrement du fichier Zip
                    Target_Folder = Set_WinDows_Folder("S:\Administration\FOURNISSEURS\Fournisseurs " & An & "\Zip-UNZIP\test\" & Fournisseur & "\" & Facture)
                    Zip_File = Target_Folder & .FileName
                    .SaveAsFile Zip_File
                   
                   ' 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
                    Kill Zip_File
                End With
                Exit For
            End Select
        Next
    End Select
End Sub

Function Set_Outlook_Folder(Mapi As MAPIFolder, Target_Folder As Variant) As MAPIFolder
    Dim Folder As 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

Dossier Window :	Dossier Outlook :

DELATTE · 11 Décembre 2024

Bonsoir,

Merci encore pour votre retour mais au lancement de la macro, ce message s'affiche :

Avez-vous une idée ?

Bien à vous,

fanch55 · 11 Décembre 2024

Vérifiez si vous avez ces bibliothèques en ligne :

Sinon, faites une exécution pas à pas en cliquant sur le bouton à chaque instruction,
vous allez atteindre la ligne dont il ne connait pas l'objet et communiquez le moi .

DELATTE · 13 Décembre 2024

Bonjour,

Voici le message d'erreur :

Merci encore.

Bien à vous,

fanch55 · 13 Décembre 2024

Pourriez-vous faire une exécution "pas à pas" et m'indiquer quelle est la ligne qui provoque cette erreur ?
Pouvez-vous me fournir une capture écran des vos références de projet ?
Je suis désolé, chez-moi tout fonctionne correctement mais je suis en outlook 2021 et pas 365, mais cela devrait être "normalement" identique .... 🤔

fanch55 · 15 Décembre 2024

L'erreur qui vous est affichée indique qu'il n'y a pas de boite à lettre pour le destinataire demandé .
Le code suivant prévient de cette anomalie :
Corrigez les constantes en début de module ....

VB:

Option Compare Text

Const Emetteur = "info@efact.public.lu"
Const Destinataire = "accounting@societe.lu"

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, Line As Variant
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))
            
            Case Trim(Line(L)) Like "*émission de la facture*": Requis = Requis + 1
                W = Split(Trim(Line(L + 1)), "-")
                Mois = W(1)
                An = W(2)
            
            Case Trim(Line(L)) = "Émetteur :": Requis = Requis + 1
                Fournisseur = Trim(Line(L + 1))
                
            Case Requis = 3
'               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
'               -------------------------------------------------------------------------------------------------
'               Décommenter la ligne suivante pour déplacer réellement le mail
                Set Mail = Mail.Move(Folder)
'               -------------------------------------------------------------------------------------------------
                With Mail.Attachments.Item(1) ' Fichier joint
                   ' enregistrement du fichier Zip
                    Target_Folder = Set_WinDows_Folder( _
                        "S:\Administration\FOURNISSEURS\Fournisseurs " & An & "\Zip-UNZIP\test\" & Fournisseur & "\" & Facture)
                    Zip_File = Target_Folder & .FileName
                    .SaveAsFile Zip_File
                    
                   ' 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
                    Kill Zip_File
                End With
                Exit For
            End Select
        Next
    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

DELATTE · 16 Décembre 2024

Bonjour,

Je viens de modifier l'adresse email accounting@societe.lu par accounting sans extension.

Et cela avance dans la macro :

En avançant pas à pas, plus rien ne bloque mais j'ai l'impression que le dézippage ne se fait pas, car le fichier zip n'est pas en pièce jointe mais dans un lien hypertexte dans le corps de l'email :

20241204_facture électronique_20241086.zip

"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 ne sais pas si c'est possible d'adapter cela.

Pour le moment, le sous dossier Outllok ne se créé pas non plus.

Ne cherchez pas trop longtemps si vous avez d'autres sujets à traiter. 😉

Merci encore,

fanch55 · 16 Décembre 2024

Dans le code joint, l'exécution a été rendue verbeuse (bavarde) ....
Si tout se passe correctement, vous devriez avoir le rapport suivant dans le volet Exécution:

Je suis parti du principe que le Zip était un lien ( fichier externe),
mais si cela ne fonctionne pas, fournissez-moi une copie de ce qui est dans votre lien .

VB:

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

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 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(Split(Z(1), ":")(1), ">", ""))
                Zip_Source = Replace(Zip_Source, "/", "\")
                Debug.Print , "Fichier Zip trouvé ( " & Zip_File & " <= " & Zip_Source & " )"
            
            Case Trim(Line(L)) Like "*émission de la facture*": Requis = Requis + 1
                W = Split(Trim(Line(L + 1)), "-")
                Mois = W(1)
                An = W(2)
                Debug.Print , "Mois et An trouvés ( " & Mois & "/" & An & " )"
            
            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
'               -------------------------------------------------------------------------------------------------
'               Décommenter la ligne suivante pour déplacer réellement le mail
                Debug.Print , "Archivage du mail dans " & Folder.FolderPath
                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
                 FileCopy Zip_Source, Zip_File
                
                ' dé-Zippage
                 With CreateObject("Shell.Application")
                 Debug.Print , "Dézippage"
                     ' 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
                Exit For
            End Select
        Next
        Debug.Print "Fin de Traitement"
    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
Sub Store_mail()
                With Mail.Attachments.Item(1) ' Fichier joint
                   ' enregistrement du fichier Zip
                    Target_Folder = Set_WinDows_Folder( _
                        "F:\Administration\FOURNISSEURS\Fournisseurs " & An & "\Zip-UNZIP\test\" & Fournisseur & "\" & Facture)
                    Zip_File = Target_Folder & .FileName
                    Debug.Print , "stockage du zip dans " & Target_Folder
                    .SaveAsFile Zip_File
                    
                   ' dé-Zippage
                    With CreateObject("Shell.Application")
                    Debug.Print , "dézippage"
                        ' 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
                End With

End Sub

DELATTE · 17 Décembre 2024

Bonjour fanch55,

Je viens de relancer la macro pas à pas avec vos modfications mais rien ne se passe dans la création des sous-dossiers Outlook. Un nouveau message d'erreur s'affiche car la date et l'année ne sont pas trouvées.

Je vous joins l'email original qui sera peut-être plus utile pour vous.

Il faut peut-être utilisé les données de l'objet de l'email pour plus de facilités (date, emetteur, numéro de facture). La construction de l'objet est toujours la même.

Encore un grand merci à vous.

Excellente journée.

Cordialement,

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

DELATTE

XLDnaute Nouveau

fanch55

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Nouveau

DELATTE

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Nouveau

fanch55

XLDnaute Barbatruc

DELATTE

XLDnaute Nouveau

Pièces jointes

Discussions similaires

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

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

Discussions similaires

Privacy & Transparency

Privacy & Transparency