Bonjour à tous,
J'ai bidouillé un code pour qu'un fichier excel qui m'est envoyé sur ma boite mail soit traité pour avoir un récap des données de ce fichier par mail.
Le but est d'avoir un récap par mail du nombre de palette et du poids des palettes par pays et par SHIP_VIA.
Je vous met en PJ un exemple de fichier qui m'est envoyé.
Et voici ce que j'ai pu coder pour l'instant, dans le code ci-dessous j'ouvre le fichier pour copier les données sur un autre classeur.
Ce que je souhaite c'est d'ouvrir le classeur qui m'est envoyé par mail effectuer un tcd et envoyer le tcd par mail puis supprimer le mail de base.
En espérant avoir été clair.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim objNamespace As Outlook.NameSpace
Dim objMail As Outlook.MailItem
Dim objAttachment As Outlook.attachment
Dim strDownloadFolder As String
Dim strSubject As String
Dim heureDebut As Date
heureDebut = Now
' Définir le dossier de téléchargement
strDownloadFolder = Environ("USERPROFILE") & "\Downloads\"
' Obtenir la référence à l'espace de noms Outlook
Set objNamespace = Application.GetNamespace("MAPI")
On Error Resume Next
' Parcourir chaque EntryID dans la collection
For Each EntryID In Split(EntryIDCollection, ",")
' Obtenir le courriel par son EntryID
Set objMail = objNamespace.GetItemFromID(EntryID)
' Vérifier si l'objet du courriel est "rapport Manhattan"
strSubject = objMail.Subject
If InStr(1, strSubject, "rapport Manhattan", vbTextCompare) > 0 Then
' Parcourir tous les fichiers joints
For Each objAttachment In objMail.Attachments
' Vérifier le type MIME du fichier joint
If objAttachment.Type = olByValue Then
' Vérifier si le fichier joint est une image dans le corps HTML du courriel
If IsImageInHtmlBody(objMail, objAttachment) = False Then
' Enregistrer le fichier joint dans le dossier de téléchargement
objAttachment.SaveAsFile strDownloadFolder & objAttachment.FileName
Dim XlApp As Object
Dim XlClas As Object
Dim ws As Object
Dim wsTCD As Object
Dim TCDRange As String
Dim Dossier As String
Dim Fichier As String
Dim lg As Long
Dim a As Long
Dim XlBaseClas As Object
Dim wsBase As Object
Dossier = Environ("USERPROFILE") & "\Downloads\"
Fichier = Dir(Dossier & "Report*.xlsx")
' Création d'un Excel
Set XlApp = CreateObject("Excel.Application")
'***********************************************************************
XlApp.Visible = False ' Rend Excel visible (en arrière-plan)
XlApp.ScreenUpdating = False ' Désactiver les mises à jour d'écran
'***********************************************************************
XlApp.DisplayAlerts = False
' Ouverture du classeur
Set XlClas = XlApp.Workbooks.Open(Dossier & Fichier)
Set ws = XlClas.Sheets(1)
lg = ws.Range("B2").End(xlDown).Row + 1
For a = lg To 3 Step -1
test = ws.Range("M" & a)
If ws.Range("M" & a) <> "EXW" Then
ws.Rows(a).Delete
End If
Next a
Set XlBaseClas = XlApp.Workbooks.Open(Environ("USERPROFILE") & "\Desktop\Report Base.xlsx")
' Sélectionner la feuille 1 du classeur ouvert
Set wsBase = XlBaseClas.Sheets(1)
wsBase.Cells.Clear
ws.UsedRange.Copy Destination:=wsBase.Range("A1")
lg = wsBase.Range("B2").End(xlDown).Row
' Convertir les données en nombre
Dim cell As Range
For Each cell In wsBase.Range("X3:AF" & lg)
If IsNumeric(cell.Value) Then
cell.Value = CDbl(cell.Value)
Else
cell.Value = Val(cell.Value)
End If
Next cell
XlBaseClas.RefreshAll
' Réactiver les mises à jour d'écran et le calcul automatique
XlApp.ScreenUpdating = True
' Sauvegarde des modifications et fermeture du classeur
XlClas.Save
XlClas.Close True
XlBaseClas.Save
XlBaseClas.Close True
' On quitte Excel
XlApp.Quit
' On libère la mémoire des variables
XlApp.DisplayAlerts = True
Set XlClas = Nothing
Set XlApp = Nothing
Kill XlClas
End If
End If
Next objAttachment
End If
Next EntryID
' Nettoyer les objets
Set objMail = Nothing
Set objAttachment = Nothing
Set objNamespace = Nothing
' Enregistrez l'heure de fin
Dim heureFin As Date
heureFin = Now
' Calculez la durée totale
Dim duree As Double
duree = DateDiff("s", heureDebut, heureFin)
' Affichez la durée
MsgBox "Temps d'exécution : " & Format(duree, "0") & " secondes", vbInformation, "Temps d'exécution"
End Sub
Function IsImageInHtmlBody(ByVal mail As Outlook.MailItem, ByVal attachment As Outlook.attachment) As Boolean
Dim body As String
Dim tempFile As String
' Créer un fichier temporaire pour l'enregistrement de la pièce jointe
tempFile = Environ("TEMP") & "\" & attachment.FileName
attachment.SaveAsFile tempFile
' Lire le corps HTML du courriel
body = mail.HTMLBody
' Vérifier si le fichier joint est inclus dans le corps HTML du courriel
IsImageInHtmlBody = InStr(body, "cid:" & attachment.FileName) > 0
' Supprimer le fichier temporaire
Kill tempFile
End Function
J'ai bidouillé un code pour qu'un fichier excel qui m'est envoyé sur ma boite mail soit traité pour avoir un récap des données de ce fichier par mail.
Le but est d'avoir un récap par mail du nombre de palette et du poids des palettes par pays et par SHIP_VIA.
Je vous met en PJ un exemple de fichier qui m'est envoyé.
Et voici ce que j'ai pu coder pour l'instant, dans le code ci-dessous j'ouvre le fichier pour copier les données sur un autre classeur.
Ce que je souhaite c'est d'ouvrir le classeur qui m'est envoyé par mail effectuer un tcd et envoyer le tcd par mail puis supprimer le mail de base.
En espérant avoir été clair.
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim objNamespace As Outlook.NameSpace
Dim objMail As Outlook.MailItem
Dim objAttachment As Outlook.attachment
Dim strDownloadFolder As String
Dim strSubject As String
Dim heureDebut As Date
heureDebut = Now
' Définir le dossier de téléchargement
strDownloadFolder = Environ("USERPROFILE") & "\Downloads\"
' Obtenir la référence à l'espace de noms Outlook
Set objNamespace = Application.GetNamespace("MAPI")
On Error Resume Next
' Parcourir chaque EntryID dans la collection
For Each EntryID In Split(EntryIDCollection, ",")
' Obtenir le courriel par son EntryID
Set objMail = objNamespace.GetItemFromID(EntryID)
' Vérifier si l'objet du courriel est "rapport Manhattan"
strSubject = objMail.Subject
If InStr(1, strSubject, "rapport Manhattan", vbTextCompare) > 0 Then
' Parcourir tous les fichiers joints
For Each objAttachment In objMail.Attachments
' Vérifier le type MIME du fichier joint
If objAttachment.Type = olByValue Then
' Vérifier si le fichier joint est une image dans le corps HTML du courriel
If IsImageInHtmlBody(objMail, objAttachment) = False Then
' Enregistrer le fichier joint dans le dossier de téléchargement
objAttachment.SaveAsFile strDownloadFolder & objAttachment.FileName
Dim XlApp As Object
Dim XlClas As Object
Dim ws As Object
Dim wsTCD As Object
Dim TCDRange As String
Dim Dossier As String
Dim Fichier As String
Dim lg As Long
Dim a As Long
Dim XlBaseClas As Object
Dim wsBase As Object
Dossier = Environ("USERPROFILE") & "\Downloads\"
Fichier = Dir(Dossier & "Report*.xlsx")
' Création d'un Excel
Set XlApp = CreateObject("Excel.Application")
'***********************************************************************
XlApp.Visible = False ' Rend Excel visible (en arrière-plan)
XlApp.ScreenUpdating = False ' Désactiver les mises à jour d'écran
'***********************************************************************
XlApp.DisplayAlerts = False
' Ouverture du classeur
Set XlClas = XlApp.Workbooks.Open(Dossier & Fichier)
Set ws = XlClas.Sheets(1)
lg = ws.Range("B2").End(xlDown).Row + 1
For a = lg To 3 Step -1
test = ws.Range("M" & a)
If ws.Range("M" & a) <> "EXW" Then
ws.Rows(a).Delete
End If
Next a
Set XlBaseClas = XlApp.Workbooks.Open(Environ("USERPROFILE") & "\Desktop\Report Base.xlsx")
' Sélectionner la feuille 1 du classeur ouvert
Set wsBase = XlBaseClas.Sheets(1)
wsBase.Cells.Clear
ws.UsedRange.Copy Destination:=wsBase.Range("A1")
lg = wsBase.Range("B2").End(xlDown).Row
' Convertir les données en nombre
Dim cell As Range
For Each cell In wsBase.Range("X3:AF" & lg)
If IsNumeric(cell.Value) Then
cell.Value = CDbl(cell.Value)
Else
cell.Value = Val(cell.Value)
End If
Next cell
XlBaseClas.RefreshAll
' Réactiver les mises à jour d'écran et le calcul automatique
XlApp.ScreenUpdating = True
' Sauvegarde des modifications et fermeture du classeur
XlClas.Save
XlClas.Close True
XlBaseClas.Save
XlBaseClas.Close True
' On quitte Excel
XlApp.Quit
' On libère la mémoire des variables
XlApp.DisplayAlerts = True
Set XlClas = Nothing
Set XlApp = Nothing
Kill XlClas
End If
End If
Next objAttachment
End If
Next EntryID
' Nettoyer les objets
Set objMail = Nothing
Set objAttachment = Nothing
Set objNamespace = Nothing
' Enregistrez l'heure de fin
Dim heureFin As Date
heureFin = Now
' Calculez la durée totale
Dim duree As Double
duree = DateDiff("s", heureDebut, heureFin)
' Affichez la durée
MsgBox "Temps d'exécution : " & Format(duree, "0") & " secondes", vbInformation, "Temps d'exécution"
End Sub
Function IsImageInHtmlBody(ByVal mail As Outlook.MailItem, ByVal attachment As Outlook.attachment) As Boolean
Dim body As String
Dim tempFile As String
' Créer un fichier temporaire pour l'enregistrement de la pièce jointe
tempFile = Environ("TEMP") & "\" & attachment.FileName
attachment.SaveAsFile tempFile
' Lire le corps HTML du courriel
body = mail.HTMLBody
' Vérifier si le fichier joint est inclus dans le corps HTML du courriel
IsImageInHtmlBody = InStr(body, "cid:" & attachment.FileName) > 0
' Supprimer le fichier temporaire
Kill tempFile
End Function
