Recuperation/Transformation Body de mails Outlook

Dannan

XLDnaute Nouveau
Bonjour a tous,

Afin des donnes importantes, j'ai recuperer l'historique d'un chat Bloomberg" par mail. Afin d'eviter les trop gros stockages, mon IT (ou BBG) ne stocke ce chat que par petits morceaux dans un grand nombre de fichiers. J'ai recu ses fichiers par mails ce matin. Il s'agit de + de 1500 mails et l'historique du chat est directement dans le body du mail.
J'ai l'habitude de coder en VBA mais je n'ai eu qu'une seule fois l'occasion de le coder pour outlook.

Ce que je souhaiterai faire, c'est d'aller de faire une boucle "for" sur tous les mails en question (qui sont dans le folder "Bloomberg" de ma boite de reception) de copier le texte qui est en body de l'email et de coller les bodys les uns a la suite des autres dans un bloc note (ce qui me permet d enlever les formats etranges).

J'essaie de m'inspirer d'un code que j'avais fait pour extraire une piece jointe d un mail cible mais je n'arrive pas a manipuler le Body d'un mail + le bloc note


"
Sub BBG()

Dim MonApp As Outlook.Application
Dim MonNameSpace As Outlook.Namespace
Dim MonDossier As Outlook.Folder
Dim MonMail As Outlook.MailItem
Dim numero As Integer
Dim strAttachment As String
Dim NbAttachments As Integer
Dim chemin As String
Dim datejour As Date: datejour = Date
'Instance des objets
Set MonApp = Outlook.Application
Set MonNameSpace = MonApp.GetNamespace("MAPI")
Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
Set myNewFolder = MonDossier.Folders("Bloomberg")
numero = myNewFolder.Items.Count



For i = 0 To numero
Set MonMail = myNewFolder.Items(numero - i)

{ici je souhaiterai copier le body et le mettre a la suite dans un bloc note}

next i

End Sub
"

Pourriez vous m'aider svp ?
Merci d'avance,
Thibault
 

Dannan

XLDnaute Nouveau
Bonjour Daniel,
J'ai peur qu'en collant le texte a partir d'une cellule via VBA, l'integralite du texte se stocke seulement dans ma cellule A1.
Comme je l'ai dit je ne manipule pas les objets "Body", je les considere un peu comme des variables donc si on colle une variable dans une cellule, la cellule va prendre la valeur de toute la variable.
Tu penses que ca marcherait en passant directement sur excel ?
 

danielco

XLDnaute Accro
Non testé, mais c'est l'idée. la macro écrit sur la feuille active :

VB:
Sub BBG()

  Dim MonApp As Outlook.Application
  Dim MonNameSpace As Outlook.Namespace
  Dim MonDossier As Outlook.Folder
  Dim MonMail As Outlook.MailItem
  Dim numero As Integer
  Dim strAttachment As String
  Dim NbAttachments As Integer
  Dim chemin As String
  Dim Ligne As Long
  Dim J As Long
  Dim datejour As Date: datejour = Date
  'Instance des objets
  Set MonApp = Outlook.Application
  Set MonNameSpace = MonApp.GetNamespace("MAPI")
  Set MonDossier = MonNameSpace.GetDefaultFolder(olFolderInbox)
  Set myNewFolder = MonDossier.Folders("Bloomberg")
  numero = myNewFolder.Items.Count
  For i = 1 To numero
    Set MonMail = myNewFolder.Items(numero - i)
    Ligne = Ligne + 2
    For J = 1 To Len(MonMail.Body) Step 1024
      Ligne = Ligne + 1
      Cells(Ligne, I) = Mid(MonMail.Body, J, 1024)
    Next J
  Next i
End Sub

Daniel

PS. "Cells(Ligne, I) = Mid(MonMail.Body, J, 1024)" au lieu de "Cells(Ligne, 1) = Mid(MonMail.Body, J, 1024)"
 
Dernière édition:

Dannan

XLDnaute Nouveau
Je viens de tester le code. Ca ne separe pas les lignes malheureusement.
J ai remarque que si je colle dans word et que je copie All sur word pour le mettre sur excel ca fonctionne par contre..
Est il possible de copier coller le corps d un mail vers un document Word ?
 

danielco

XLDnaute Accro
Mets cette macro dans un document Word. La référence "Microsoft Forms 2.0 Object Library" doit être cochée.

VB:
Sub BBG()
' cocher la référence Microsoft Forms 2.0 Object Library
  Dim MonApp As Object
  Dim MonNameSpace As Object
  Dim MonDossier As Object
  Dim MonMail As Object
  Dim numero As Integer
  Dim strAttachment As String
  Dim NbAttachments As Integer
  Dim chemin As String
  Dim Ligne As Long
  Dim J As Long
  Dim datejour As Date: datejour = Date
  Dim obj As New DataObject
  Set MonApp = CreateObject("Outlook.Application")
  Set MonNameSpace = MonApp.GetNamespace("MAPI")
  Set MonDossier = MonNameSpace.GetDefaultFolder(6)
  Set myNewFolder = MonDossier.Folders("Bloomberg")
  numero = myNewFolder.Items.Count
  For i = 1 To numero
    obj.SetText myNewFolder.Items(i).body
    obj.PutInClipboard
    Selection.Paragraphs.Add
    Selection.EndKey Unit:=wdStory
    Selection.Paste
  Next i
End Sub

Daniel
 

Pièces jointes

  • teste.docm
    19 KB · Affichages: 8