• | 20241204_facture électronique_20241086.zip |
• | 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 |
Option Compare Text
Const Emetteur = "info@efact.public.lu"
Const Destinataire = "accounting@societe.lu"
'Const Emetteur = "francois.lheritier95@free.fr"
'Const Destinataire = "test.vba.fanch55@free.fr"
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 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
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(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"
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
' -------------------------------------------------------------------------------------------------
Debug.Print , "Archivage du mail dans " & Folder.FolderPath
' Décommenter la ligne suivante pour déplacer réellement le mail
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
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"
With CreateObject("Shell.Application")
' 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
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
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
Testez le code ci-joint :
Je l'ai éprouvé avec l'e-mail fourni ...
VB:Option Compare Text Const Emetteur = "info@efact.public.lu" Const Destinataire = "accounting@societe.lu" 'Const Emetteur = "francois.lheritier95@free.fr" 'Const Destinataire = "test.vba.fanch55@free.fr" 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 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 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(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" 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 ' ------------------------------------------------------------------------------------------------- Debug.Print , "Archivage du mail dans " & Folder.FolderPath ' Décommenter la ligne suivante pour déplacer réellement le mail 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 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" With CreateObject("Shell.Application") ' 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 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 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
Option Compare Text
Const Emetteur = "info@efact.public.lu"
Const Destinataire = "accounting"
Const Disque_Local = "S" ' nom du volume sur lequel stocker les fichiers dézippés
Const Move_Mail = False ' mettre à True pour déplacer effectivement le mail
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 Tracer(Line)
Doc_Folder = CreateObject("Shell.Application").NameSpace(&H5).self.Path
Fic = FreeFile
Open Doc_Folder & "\Trace_Body.txt" For Output As #Fic
For Each Lin In Line
Print #Fic, Lin
Next
Close #Fic
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 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 doubles "retour à la ligne" par un seul
' et on éclate le mail en lignes en se basant sur le "retour à la ligne"
Line = Split(Replace(Mail.Body, vbCrLf & vbCrLf, vbCrLf), 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), _
"Accounting\" & 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\" & Fournisseur & "\" & Facture)
Zip_File = Target_Folder & Zip_File
Debug.Print , "Stockage du zip dans " & Target_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"
With CreateObject("Shell.Application")
' option 16 pour tout remplacer sans poser de question
.NameSpace(Target_Folder).CopyHere .NameSpace(Zip_File).Items, 16
End With
Debug.Print , "Suppression du fichier Zip"
Kill Zip_File
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
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