Extraire le corp du mail vers un fichier XSLM
Bonjour,
Je dispose d’une macro vba qui fonctionne très bien. Elle pour objectif d’extraire les pièces jointe des mails se trouvant dans le dossier « Retours » de ma boite mails Outlook et de les déposer dans un répertoire de type C:\Macro\Fichiers. (Pour que cela fonctionne j’ai récupéré différents composants sur le net et je les ai adaptés)
Dans mon VBA : j’ai la commande suivante :
Extraction "Retours", email@email.frEt le module « Extraction » est le suivant :
Sub Extraction(NomDossier As String, Expediteur As String)
Dim OLapp As Outlook.Application
Dim OLspace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim OLinbox As Outlook.MAPIFolder
Dim olmail As Outlook.MailItem
Dim pceJointe As Outlook.Attachment
Dim y As Integer, x As Integer
Set OLapp = New Outlook.Application
Set OLspace = OLapp.GetNamespace("MAPI")
Set OLinbox = OLspace.GetDefaultFolder(olFolderInbox)
Set olFolder = OLinbox.Folders(NomDossier)
For Each olmail In olFolder.Items
For y = 1 To olmail.Attachments.Count
Set pceJointe = olmail.Attachments(y)
x = x + 1
pceJointe.SaveAsFile "C:\Macro\Fichiers\" & pceJointe
Set pceJointe = Nothing
Next y
' End If
Next olmail
End SubAujourd’hui, je voudrai récupérer ce module ‘Extraction’ pour une autre procédure qui me permettrait d’extraire le corps d’autres mails un par un pour les déposer dans un fichier Excel contenant déjà une macro.
Car je récupère le contenu d’une dizaine de mails chaque jour que je copie colle un par un dans ce fichier et après chaque collage je lance ma macro permettant le remodelage de toutes les informations du mail pour les intégrer dans une base Excel exploitable.
Mais je n’arrive pas à adapter le module. J’ai testé différentes choses trouvées sur le net mais rien n’aboutit. Pourtant je suis convaincu qu’il n’y aurait pas grande chose à faire pour que cela fonctionne.
En résumé
- Je dépose mes mails dans le répertoire ‘Retours’
- Je lance la macro qui récupère le corps du premier mail (peu importe l’ordre) afin de la déposer sur la cellule A1 de mon intégration.xlsm
- La macro lancerait ensuite le [CTRL]+[M] de la procédure déjà existante pour le remodelage
- Enfin, elle irait chercher le contenu du second mail, ainsi de suite.
Pourriez-vous me guider ?
Merci
Bonjour Fabien,
Peux-tu fournir une copie anonymisée de "Integration.xlsm" ?
Bonjour Gérard,
J'essaie pense pouvoir intégrer mon fichier, mais je ne sais pas si j'aurai le temps d'en télécharger un. Merci d'avance pour ton aide.
Fabien
Fabien,
Peux-tu confirmer que tu veux copier le message en "A1" de la feuille "SPOOL" ?
Une petite erreur dans mon texte : "si j'aurai le temps d'en télécharger un". Je voulais dire qu'avec la sécurité je ne pense pas pouvoir télécharger un fichier.
Fabien,
C'est bon, j'avais traduit...
Je te propose d'utiliser le presse-papier pour copier le contenu du corps des mails et les copier en "A1" de la feuille SPOOL.
Pou que ça marche, tu dois référencer "MSForms" - le plus simple consiste à créer une userform dans ton projet VBA : le référencement de "MSForms" va se faire automatiquement puis tu supprimes la userform.
Le code proposé partant du module "Extraction":
Sub ScanMails(NomDossier As String)
Const sCopieAddress = "A1"
Dim oSheet As Worksheet
Dim oRange As Range
Dim sBody As String
Dim oDO As MSForms.DataObject 'Pour utiliser le presse-papier
Dim OLapp As Outlook.Application
Dim OLspace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim OLinbox As Outlook.MAPIFolder
Dim olmail As Outlook.MailItem
Dim y As Integer, x As Integer
Set OLapp = New Outlook.Application
Set OLspace = OLapp.GetNamespace("MAPI")
Set OLinbox = OLspace.GetDefaultFolder(olFolderInbox)
Set olFolder = OLinbox.Folders(NomDossier)
Set oSheet = ThisWorkbook.Worksheets("SPOOL")
Set oRange = oSheet.Range(sCopieAddress)
For Each olmail In olFolder.Items 'On parcourt tous les mails contenus dans le dossier
oSheet.UsedRange.Clear 'On efface le contenu de SPOOL
sBody = olmail.Body 'On récupère le corps du mail
Set oDO = New MSForms.DataObject 'On réfère le presse-papier
oDO.SetText sBody 'On réfère le corps du mail
oDO.PutInClipboard 'On copie le corps du mail dans le presse papier
oRange.Select 'On sélectionne la cellule "A1" de la feuille SPOOL
oSheet.Paste 'On recopie le contenu du presse-paier
MAJ 'On passe la main au module de traduction
Next olmail
End SubMerci je teste cela dès que possible et te tiens au courant
J'essaie de ne pas appliquer bêtement cela n'a pas d'intérêt.
J'ai fini par comprendre que mon MAJ ne pouvait pas être dans mon fichier final mais dans le fichier qui lance la macro générale. Et l'onglet SPOOL également, quitte a recopier ensuite les éléments du fichier global vers la base de donnée en fin de procédure. Tu confirmes ?
J'ai été perturbé aussi par :
Dim y As Integer, X As Integer
J'ai d'abord pensé que je devais rajouter une boucle. Mais finalement c'est peut être juste un oublie. Il faut le retirer n'est-ce pas ?
Ce que je comprends c'est que l'on ne peut pas lancer directement les actions du press papier par un simple :
Selection.copy
ActiveSheet.paste
C'est la raison pour laquelle on passe par des variables.
Je pense avoir compris la démarche globale.
Cependant, la commande oRange.Select n'arrive pas à faire son travaille, elle n'active pas l'onglet SPOOL
J'ai l'erreur suivante : Erreur d'execution 1004 La méthode Select de la classe Range a échoué.
Me serais-je fourvoyé ?
Merci pour ton retour
Pourtant il repère bien SPOOL car je mets volontairement des caractères dans SPOOL et il les efface.
bon, en fait j'ai fini par remplacer par quelque chose de plus simple :
Sheets("SPOOL").Select
Range("A1").Select
' oRange.Select
Et ça fonctionne apparemment, je vais poursuivre.
En tout cas un grand merci.
Bonne journée
Fabien
Fabien,
J'ai fini par comprendre que mon MAJ ne pouvait pas être dans mon fichier final mais dans le fichier qui lance la macro générale. Et l'onglet SPOOL également, quitte a recopier ensuite les éléments du fichier global vers la base de donnée en fin de procédure. Tu confirmes ?
C'est bien ça.
J'ai été perturbé aussi par :
Dim y As Integer, X As Integer
J'ai d'abord pensé que je devais rajouter une boucle. Mais finalement c'est peut être juste un oublie. Il faut le retirer n'est-ce pas ?
Oui, on peut effacer. Partant de ton module 'Extraction', j'ai l'ai modifié un minimum pour que tu t'y repères.
Ce que je comprends c'est que l'on ne peut pas lancer directement les actions du press papier par un simple :
Selection.copy
ActiveSheet.paste
C'est la raison pour laquelle on passe par des variables.
Tu as bien compris. Un 'simple' Selection.copy de peut copier que ce qui figure déjà dans la feuille. Or tu cherches à copier le contenu d'un message...
Cependant, la commande oRange.Select n'arrive pas à faire son travaille, elle n'active pas l'onglet SPOOL
J'ai l'erreur suivante : Erreur d'execution 1004 La méthode Select de la classe Range a échoué.
Difficile de comprendre ton problème sans pouvoir juger sur pièce. Peux-tu joindre la nouvelle version de ton classeur qui renvoit l'erreur?
Bonjour Gérard,
désolé pour mon temps de réactivité. Priorité à la prod :)
Je pensais que cela avait fonctionné, mais je me suis trompé. La procédure AJ n'arrive pas à faire son travail correctement.
Voici la procédure comme tu me l'as demandé (En plusieurs étapes car elle est longue)
Sub ScanMails(NomDossier As String)
Const sCopieAddress = "A1"
Dim oSheet As Worksheet
Dim oRange As Range
Dim sBody As String
Dim oDO As MSForms.DataObject 'Pour utiliser le presse-papier
Dim OLapp As Outlook.Application
Dim OLspace As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim OLinbox As Outlook.MAPIFolder
Dim olmail As Outlook.MailItem
Dim y As Integer, X As Integer
Set OLapp = New Outlook.Application
Set OLspace = OLapp.GetNamespace("MAPI")
Set OLinbox = OLspace.GetDefaultFolder(olFolderInbox)
Set olFolder = OLinbox.Folders(NomDossier)
Set oSheet = ThisWorkbook.Worksheets("SPOOL")
Set oRange = oSheet.Range(sCopieAddress)
For Each olmail In olFolder.Items 'On parcourt tous les mails contenus dans le dossier
oSheet.UsedRange.Clear 'On efface le contenu de SPOOL
sBody = olmail.Body 'On récupère le corps du mail
Set oDO = New MSForms.DataObject 'On répère le presse-papier
oDO.SetText sBody 'On répère le corps du mail
oDO.PutInClipboard 'On copie le corps du mail dans le presse papier
Sheets("SPOOL").Select
Range("A1").Select
' oRange.Select 'On sélectionne la cellule "A1" de la feuille SPOOL
oSheet.paste 'On recopie le contenu du presse-paier
MAJ 'On passe la main au module de traduction
Next olmail
End Sub'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' '''
''' Intégration des print manager '''
''' '''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' vider le cache
Dim SourceFileBidon, DestinationFileBidon 'fichier bidon au cas où il n'y a rien à supprimer
SourceFileBidon = "C:\Macro\Retours\Masques\suivi-alertes.xlsx" ' Define source file name.
DestinationFileBidon = "C:\Macro\Retours\DATEJ\suivi-alertes.xlsx" ' Define target file name.
FileCopy SourceFileBidon, DestinationFileBidon ' Copy source to target.
Kill "C:\Macro\Retours\DATEJ\*.*"
ScanMails "Retours"
', "exemple@email.fr"'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' '''
''' Création des variables '''
''' '''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Demander la date du jour
Dim jour As Variant
jour = InputBox("Quelle est la date du jour ?" & Chr(10) & _
"Sous le format : 28022017 - en cas de prise en compte de fin de mois saisir le dernier jour du mois")
Dim jour2 As Variant
jour2 = jour
' Création variables mois et Année et jour pour publiacation dans le bon répertoire.
' Si plantage à ce niveau, recommencez tout après avoir créer le répertoire dans SharePoint
Workbooks.Open FileName:="C:\Macro\titresdate.xlsx"
Windows("titresdate.xlsx").Activate
Range("J1").Select
ActiveCell.FormulaR1C1 = "" & jour2 & ""
ActiveWorkbook.Save
Windows("titresdate.xlsx").Activate
Range("K4").Select
Dim DATEAN As Variant
DATEAN = Range("K4").Value
Windows("titresdate.xlsx").Activate
Range("K3").Select
Dim DATEMOIS As Variant
DATEMOIS = Range("K3").Value
Windows("titresdate.xlsx").Activate
Range("K5").Select
Dim DATEJJ As Variant
DATEJJ = Range("K5").Value'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' '''
''' Mise à jour du fichier du mois '''
''' '''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Téléchargement
Dim SourceEQXT, DestinationEQXT
SourceEQXT = "P:\Equinoxe\" & DATEAN & "\cumul IBP " & DATEAN & "" & DATEMOIS & ".xlsm" ' Define source file name.
DestinationEQXT = "C:\Macro\fichiers\cumul IBP " & DATEAN & "" & DATEMOIS & ".xlsm" ' Define target file name.
FileCopy SourceEQXT, DestinationEQXT ' Copy source to target.
' Ouvrir le fichier du mois
Workbooks.Open FileName:="C:\Macro\fichiers\cumul IBP " & DATEAN & "" & DATEMOIS & ".xlsm"
Windows("cumul IBP " & DATEAN & "" & DATEMOIS & ".xlsm").Activate
Sheets("SPOOL").Select
ActiveWindow.WindowState = xlMaximized
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' '''
''' Phase finale '''
''' '''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Fermeture du fichier du mois
Windows("cumul IBP " & DATEAN & "" & DATEMOIS & ".xlsm").Activate
Sheets("BANQUE").Select
ActiveWorkbook.Save
ActiveWindow.Close
' Publication
Dim SourceEQXM, DestinationEQXM
SourceEQXM = "C:\Macro\fichiers\cumul IBP " & DATEAN & "" & DATEMOIS & ".xlsm" ' Define source file name.
DestinationEQXM = "P:\Equinoxe\" & DATEAN & "\cumul IBP " & DATEAN & "" & DATEMOIS & ".xlsm" ' Define target file name.
FileCopy SourceEQXM, DestinationEQXM ' Copy source to target.
' Suppression du fichier temp
Kill "C:\Macro\fichiers\cumul IBP " & DATEAN & "" & DATEMOIS & ".xlsm"
' Fermeture des fichiers
Workbooks("titresdate.xlsx").Close SaveChanges:=False
Public Sub MAJ()
' Récupérer l'heure de transmission
Dim Heure As String
Dim Time As String
Heure = Range("A2").Value
Time = Right(Heure, 12)
' Concatener les lignes
Dim iDerLig As Integer
Dim iLig As Integer
Dim sMot As String
Dim icpt As Integer
sMot = "lot logique"
Sheets("Spool").Select
Range("A1").Select
If sMot = "" Then
Exit Sub
End If
sMot = UCase(sMot)
iDerLig = Range("A" & Rows.Count).End(xlUp).Row
icpt = 0
For iLig = 4 To iDerLig
If InStr(1, UCase(Range("A" & iLig)), sMot) > 0 Then
'ajoute à la ligne précédente
Range("A" & iLig - 1).Value = Range("A" & iLig - 1).Value & " " & Range("A" & iLig).Value
'efface la ligne
Range("A" & iLig).Value = ""
icpt = icpt + 1
End If
Next iLig
' Supprimer les lignes inutiles
Dim i As Integer
Application.ScreenUpdating = False
For i = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & i).Value Like "*LES LOTS *" Then Rows(i).Delete
Next i
Application.ScreenUpdating = True
Range("A1").Select
Dim J As Integer
Application.ScreenUpdating = False
For J = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & J).Value Like "*DEBDISPO*" Then Rows(J).Delete
Next J
Application.ScreenUpdating = True
Range("A1").Select
Dim K As Integer
Application.ScreenUpdating = False
For K = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & K).Value Like "*FINDISPO*" Then Rows(K).Delete
Next K
Application.ScreenUpdating = True
Range("A1").Select
Dim L As Integer
Application.ScreenUpdating = False
For L = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & L).Value Like "*Ce message*" Then Rows(L).Delete
Next L
Application.ScreenUpdating = True
Range("A1").Select
Dim M As Integer
Application.ScreenUpdating = False
For M = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & M).Value Like "*Merci*" Then Rows(M).Delete
Next M
Application.ScreenUpdating = True
Range("A1").Select
Dim N As Integer
Application.ScreenUpdating = False
For N = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & N).Value Like "* FIN DU TRAITEMENT*" Then Rows(N).Delete
Next N
Application.ScreenUpdating = True
Range("A1").Select
Dim O As Integer
Application.ScreenUpdating = False
For O = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & O).Value Like "*--------------*" Then Rows(O).Delete
Next O
Application.ScreenUpdating = True
Range("A1").Select
Dim P As Integer
Application.ScreenUpdating = False
For P = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & P).Value Like "* lots envoyés dans le spool*" Then Rows(P).Delete
Next P
Application.ScreenUpdating = True
Range("A1").Select
Dim Q As Integer
Application.ScreenUpdating = False
For Q = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & Q).Value Like "* *" Then Rows(Q).Delete
Next Q
Application.ScreenUpdating = True
Range("A1").Select
Dim R As Integer
Application.ScreenUpdating = False
For R = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
If Range("A" & R).Value Like "*ADHERENT*" Then Rows(R).Delete
Next R
Application.ScreenUpdating = True
' supprimer les lignes vides
Range("a1:a65536").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
' convertir en colonnes
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="-", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1), Array(6, 1), Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
' largeur de colonnes
Columns("A:I").Select
Columns("A:I").EntireColumn.AutoFit
' retirer les colonnes et mots inutiles
Columns("C:E").Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Selection.Replace What:=" EXTERIEUR", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="plis ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("D:D").Select
Selection.Replace What:="pages ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("D:E").Select
Range("E1").Activate
Selection.NumberFormat = "#,##0 _€"
' ajouter champs A
Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Extraire la lettre de la banque
Dim Z As Integer
Z = Application.WorksheetFunction.CountA(Range("B:B"))
Dim X As Integer
Application.ScreenUpdating = False
For X = 1 To Z
Range("A" & X).FormulaR1C1 = "=MID(RC[1],3,1)"
Next X
' Ajouter l'heure de transmission sur chaque ligne
' Range("G1").Value = Time
Dim A As Integer
A = Application.WorksheetFunction.CountA(Range("B:B"))
Dim B As Integer
Application.ScreenUpdating = False
For B = 1 To A
Range("G" & B).FormulaR1C1 = Time
Next B
Columns("G:G").Select
Selection.Replace What:=" ***", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Couper les données et coller vers le cumul
Range("A1:G" & Z).Select
Application.CutCopyMode = False
Selection.Cut
' Sélectionner le première cellule vide du cumul
Sheets("Cumul BP").Select
Range("A1").Select
Range("A1").End(xlDown).Offset(1, 0).Select
ActiveSheet.paste
' repositionnement et vidage spool
Sheets("SPOOL").Select
Range("A1").Select
End Sub