IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

VBA Outlook Discussion :

Extraction de contenu de mail avec date, destinaire et expéditeur


Sujet :

VBA Outlook

  1. #1
    Membre régulier
    Profil pro
    Inscrit en
    mai 2008
    Messages
    235
    Détails du profil
    Informations personnelles :
    Localisation : France, Rhône (Rhône Alpes)

    Informations forums :
    Inscription : mai 2008
    Messages : 235
    Points : 75
    Points
    75
    Par défaut Extraction de contenu de mail avec date, destinaire et expéditeur
    Bonjour,
    Je ne m'y connais que très peut pour ne pas dire pas du tout en VB.
    Et on m'a demandé de faire une macro pour l'extraction et la sauvegarde mail contenu dans certains dossier dont le nom sera à renseigner par l'utilisateur.
    Il faudrait donc que cette macro demande le nom du dossier à sauvegarder, se place dessus,compte le nombre de mail, puis fait une boucle pour récupèrer le contenu, la date, l'expéditeur, le destinataire et l'objet du message. Puis enregistre le tout à un endroit donner avec dans le nom du fichier l'objet, la date, expéditeur et destinataire.

    Je pense que le boulot est plutôt conséquent...
    Si des âmes charitables sont prête à m'aider cela serai apprécié grandement .

    Voici pour le moment, le peut que j'ai (et encore si cela est correct).

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
     
    Sub ExtraireMail()
    'Declaration des variables
    Dim ContenuMail, Expediteur, Destinataire, Titre, MonDossier() As String
    Dim nbmail, i, j, NiveauDossier As Integer
    Dim Dossier As Outlook.MAPIFolder
    Dim DateRe As Date
    Dim MonApp As Outlook.Application
    Dim MonNameSpace As Outlook.NameSpace
    Dim OutlookFolder As Outlook.Folder
    Dim MonMail As Outlook.MailItem
     
    'On recupere le dossier à extraire
     NiveauDossier = InputBox("A quel niveau se situe le dossier? 1 pour un sous-dossier direct, 2 pour un sous-dossier de sous-dossier etc", "Nombre de sous-dossier")
     ReDim MonDossier(NiveauDossier)
     
    'On se place dans le bon dossier dans Outlook si c'est un sous-dossier direct
    If NiveauDossier = 1 Then
        MonDossier(1) = InputBox("Renseigner le nom du sous-dossier ", "Nom du sous-dossier")
        Set MonApp = Outlook.Application
        Set MonNameSpace = MonApp.GetNamespace("MAPI")
        Set Dossier = MonNameSpace.GetDefaultFolder(olFolderInbox).Folders(MonDossier(1))
    'On compte le nombre de mail du dossier
        nbmail = Dossier.Items.Count
    Else
     'On se place dans le bon dossier en fonction du nombre de sous-dossier
     
        For j = 1 To NiveauDossier
            MonDossier(j) = InputBox("Renseigner le nom du sous-dossier dans l'ordre ", "Nom du sous-dossier")
        Next
        'On se place dans le bon dossier dans Outlook
        Set MonApp = Outlook.Application
        Set MonNameSpace = MonApp.GetNamespace("MAPI")
        'Set Dossier = MonNameSpace.GetDefaultFolder(olFolderInbox).Folders(MonDossier)
        'On compte le nombre de mail du dossier
        nbmail = Dossier.Items.Count
    End If
     
     
     
     
    'On recupere les infos du mail
     'For i = 1 To nbmail
     '   Set MonMail = Dossier.Items(i)
     '   With MonMail
     '       DateRe = strInfos & vbCr & .ReceivedTime
     '       Expediteur = strInfos & vbCr & .SenderName
     '       Destinataire = strInfos & vbCr & .Recipients
     '       ContenuMail = strInfos & vbCr & .Body
     '       Titre = strInfos & vbCr & .Subject
     '   End With
     ' Next
     
     
     
    End Sub
    Il me manque la partie pour me placer dans le bon sous-dossier si il y en a plusieurs. Et la fonction pour compter les mails si il y a plusieurs sous-dossier.
    Je ne sais pas comment enregistrer en .msg.
    D'avance merci.

  2. #2
    Membre régulier
    Profil pro
    Inscrit en
    mai 2008
    Messages
    235
    Détails du profil
    Informations personnelles :
    Localisation : France, Rhône (Rhône Alpes)

    Informations forums :
    Inscription : mai 2008
    Messages : 235
    Points : 75
    Points
    75
    Par défaut
    J'ai modifie mon compte.
    Pour le moment j'arrive a stocker les différentes infos dans un tableau, si le dossier choisis est directement un sous-dossier de boites de réception.

    Par contre, je ne sais pas récupérer les infos si le dossier sélectionner est un sous-dossier d'un sous-dossier etc.

    Et je ne sais pas enregistrer les valeurs de mon tableau sous la forme : "objet.date.destinataire.eml" avec dans le contenue le corps du message.

    Voici mon code actuel :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    Sub ExtraireMail()
    'Declaration des variables
    Dim ContenuMail(), Expediteur(), Destinataire(), Titre(), DateRe(), MonDossier() As String
    Dim nbmail, i, j, NiveauDossier As Integer
    Dim Dossier As Outlook.MAPIFolder
    Dim MonApp As Outlook.Application
    Dim MonNameSpace As Outlook.NameSpace
    Dim OutlookFolder As Outlook.Folder
    Dim MonMail As Outlook.MailItem
     
    'On recupere le dossier à extraire
     NiveauDossier = InputBox("A quel niveau se situe le dossier? 1 pour un sous-dossier direct, 2 pour un sous-dossier de sous-dossier etc", "Nombre de sous-dossier")
     ReDim MonDossier(NiveauDossier)
     
    'On se place dans le bon dossier dans Outlook si c'est un sous-dossier direct
    If NiveauDossier = 1 Then
        MonDossier(1) = InputBox("Renseigner le nom du sous-dossier ", "Nom du sous-dossier")
        Set MonApp = Outlook.Application
        Set MonNameSpace = MonApp.GetNamespace("MAPI")
        Set Dossier = MonNameSpace.GetDefaultFolder(olFolderInbox).Folders(MonDossier(1))
    'On compte le nombre de mail du dossier
        nbmail = Dossier.Items.Count
        ReDim DateRe(nbmail)
        ReDim Expediteur(nbmail)
        ReDim Destinataire(nbmail)
        ReDim ContenuMail(nbmail)
        ReDim Titre(nbmail)
        'On recupere les infos du mail
        For i = 1 To nbmail
            'Set MonMail = Dossier.Items(i)
            'With MonMail
            With Dossier.Items(i)
                DateRe(i) = strInfos & vbCr & .ReceivedTime
                Expediteur(i) = strInfos & vbCr & .SenderName
                'Destinataire(i) = strInfos & vbCr & .Recipients
                ContenuMail(i) = strInfos & vbCrs & .Body
                Titre(i) = strInfos & vbCr & .Subject
            End With
        Next
    Else
     'On se place dans le bon dossier en fonction du nombre de sous-dossier
     
        For j = 1 To NiveauDossier
            MonDossier(j) = InputBox("Renseigner le nom du sous-dossier dans l'ordre ", "Nom du sous-dossier")
        Next
        'On se place dans le bon dossier dans Outlook
        Set MonApp = Outlook.Application
        Set MonNameSpace = MonApp.GetNamespace("MAPI")
        'Set Dossier = MonNameSpace.GetDefaultFolder(olFolderInbox).Folders(MonDossier)
        'On compte le nombre de mail du dossier
        nbmail = Dossier.Items.Count
    End If
     
     
    'Enregistrement des mails
    For i = 1 To nbmail
        ContenuMail(i).SaveAs "C:\" & Titre(i) & DateRe(i) & Expediteur(i) & ".msg", olMSG
    Next
     
     
    End Sub

  3. #3
    Expert éminent
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    4 083
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 50
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 4 083
    Points : 7 035
    Points
    7 035
    Billets dans le blog
    20
    Par défaut
    bonjour,
    tu peux utiliser cela
    http://outlook.developpez.com/faq/?p...#VBA_save_mail

    avec cette boucle récursive

    http://www.developpez.net/forums/d14...e/#post7704415

    et pour choisir le dossier à exporter

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    Set objNS = Application.GetNamespace("MAPI")
                Set objFolder = objNS.PickFolder

  4. #4
    Membre régulier
    Profil pro
    Inscrit en
    mai 2008
    Messages
    235
    Détails du profil
    Informations personnelles :
    Localisation : France, Rhône (Rhône Alpes)

    Informations forums :
    Inscription : mai 2008
    Messages : 235
    Points : 75
    Points
    75
    Par défaut
    Merci de ta réponse.
    Je galérais pas mal.
    J'ai repris le code que tu m'avais dit, mais du coup ce que j'avais fait ne sert à rien.
    Par contre, le formatage de la personne ne me conviens pas, car il enlève les espaces dans le nom du fichier ainsi que le format date ":" et "/" j'aurais aimer y laisser, mais quand je remplace cette ligne :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
        PathNomExport = repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
        NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
    Par :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
        PathNomExport = repertoire & NomExport & ".msg"
    J'ai une erreur. "erreur d'exécution '-2147286788 800300fc)': échec de l'opération.

    Autant pour moi, on est obliger d'enlever ces caractères dans le nom d'un fichier.

  5. #5
    Membre régulier
    Profil pro
    Inscrit en
    mai 2008
    Messages
    235
    Détails du profil
    Informations personnelles :
    Localisation : France, Rhône (Rhône Alpes)

    Informations forums :
    Inscription : mai 2008
    Messages : 235
    Points : 75
    Points
    75
    Par défaut
    J'ai donc un code de la forme :
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    Attribute VB_Name = "Module2"
     
    Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
     
        If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
     
        'Ici on construit le nom du fichier qui sera créé
        NomExport = objCurrentMessage.Subject & " " & objCurrentMessage.CreationTime & " " & objCurrentMessage.SenderName
     
        'Ici on défini le répertoire où l'enregistrer
        repertoire = "c:\temp\"
        'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
     
        'Ici on supprime les caractères non autorisé dans les noms de fichiers
        PathNomExport = repertoire & "Email " & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
        NomExport, "\", " "), "/", " "), ":", " "), "*", " "), "?", " "), "<", " "), ">", " "), "|", " "), ".", " "), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
     
        'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
        n = 1
        MemPath = PathNomExport
        While Dir(PathNomExport) <> ""
            MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
            PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
            n = n + 1
     
        Wend
        objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
     
    End Sub
     
    Sub LanceSurOuvert()
        sav_mail_as_msg
    End Sub
     
     
    Sub LanceSurSelection()
        Dim MonOutlook As Outlook.Application
        Dim LeMail As Object
        Dim LesMails As Outlook.Selection
        Set MonOutlook = Outlook.Application
     
        Set LesMails = MonOutlook.ActiveExplorer.Selection
     
        For Each LeMail In LesMails
            sav_mail_as_msg LeMail
        Next LeMail
     
        Set LesMails = Nothing
        MsgBox "Fin de traitement"
    End Sub
    Celui-ci fait le travail quasi-parfaitement.
    J'aimerais juste pouvoir modifier l'affichage de la date dans le nom du fichier, pour passer de JJMMAAAAHHMMSS à AAAAMMJJ-HHMM

  6. #6
    Expert éminent
    Avatar de Oliv-
    Homme Profil pro
    solution provider
    Inscrit en
    mars 2006
    Messages
    4 083
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 50
    Localisation : France, Nord (Nord Pas de Calais)

    Informations professionnelles :
    Activité : solution provider

    Informations forums :
    Inscription : mars 2006
    Messages : 4 083
    Points : 7 035
    Points
    7 035
    Billets dans le blog
    20
    Par défaut
    IL FAUT UTILISER
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    Format(MADate, "YYYYMMDD-hhmm")

  7. #7
    Membre régulier
    Profil pro
    Inscrit en
    mai 2008
    Messages
    235
    Détails du profil
    Informations personnelles :
    Localisation : France, Rhône (Rhône Alpes)

    Informations forums :
    Inscription : mai 2008
    Messages : 235
    Points : 75
    Points
    75
    Par défaut
    Je n'ai pas du ta réponse avant d'avoir bidouiller quelque chose.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
       Annee = Mid(objCurrentMessage.CreationTime, 7, 4)
        Mois = Mid(objCurrentMessage.CreationTime, 4, 2)
        Jour = Mid(objCurrentMessage.CreationTime, 1, 2)
        Heure = Mid(objCurrentMessage.CreationTime, 12, 5)
    Cela me donne du coup bien la date au format que je souhaite.

    Ce qui me donne un code "final" je l'espère.
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
     
    Sub sav_mail_as_msg(Optional objCurrentMessage As Object)
     
        If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
     
        'Extraction et formatage de la date
        Annee = Mid(objCurrentMessage.CreationTime, 7, 4)
        Mois = Mid(objCurrentMessage.CreationTime, 4, 2)
        Jour = Mid(objCurrentMessage.CreationTime, 1, 2)
        Heure = Mid(objCurrentMessage.CreationTime, 12, 5)
        'Ici on construit le nom du fichier qui sera créé
        NomExport = Annee & Mois & Jour & Heure & " " & objCurrentMessage.Subject & "-" & objCurrentMessage.SenderName
     
        'Ici on défini le répertoire où l'enregistrer
        repertoire = "c:\temp\"
        'repertoire = BrowseForFolder("Choisissez la destination", SDossier(5, 0)) & "\"
     
        'Ici on supprime les caractères non autorisé dans les noms de fichiers
        PathNomExport = repertoire & Left(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
        NomExport, "\", " "), "/", " "), ":", ""), "*", " "), "?", " "), "<", " "), ">", " "), "|", " "), ".", " "), """", ""), vbTab, ""), Chr(7), ""), 160) & ".msg"
     
        'Ici on vérifie que le fichier n'existe pas déjà sinon il serait écrasé
        n = 1
        MemPath = PathNomExport
        While Dir(PathNomExport) <> ""
            MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
            PathNomExport = Left(MemPath, Len(MemPath) - 4) & "(" & n & ")" & ".msg"
            n = n + 1
     
        Wend
        objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMSG
     
    End Sub
     
    Sub LanceSurOuvert()
        sav_mail_as_msg
    End Sub
     
     
    Sub LanceSurSelection()
        Dim MonOutlook As Outlook.Application
        Dim LeMail As Object
        Dim LesMails As Outlook.Selection
        Set MonOutlook = Outlook.Application
     
        Set LesMails = MonOutlook.ActiveExplorer.Selection
     
        For Each LeMail In LesMails
            sav_mail_as_msg LeMail
        Next LeMail
     
        Set LesMails = Nothing
        MsgBox "Fin de traitement"
    End Sub

  8. #8
    Nouveau Candidat au Club
    Homme Profil pro
    Ingénieur travaux (BTP)
    Inscrit en
    mai 2014
    Messages
    1
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 37
    Localisation : France, Rhône (Rhône Alpes)

    Informations professionnelles :
    Activité : Ingénieur travaux (BTP)

    Informations forums :
    Inscription : mai 2014
    Messages : 1
    Points : 1
    Points
    1
    Par défaut
    Bonjour,
    Je trouve enfin ce que je cherche depuis un moment pour m'aider dans mes archivages de mails pro. Etant totalement ignare en programmation je suis totalement incapable de faire cela. Merci beaucoup !!

    Juste un petit point : tu as mis en commentaire la commande permettant de choisir un dossier de destination. Si on l'"active" le script le ne fonctionne plus.
    As-tu/avez vous une solution ?

Discussions similaires

  1. [OL-2007] Extraction de contenu d'un mail dans Excel sur un serveur HP
    Par superstarz dans le forum VBA Outlook
    Réponses: 0
    Dernier message: 08/09/2010, 16h41
  2. Enregistrement d'un fichier Excel avec date et contenu d'une TextBox
    Par thomasisajerk dans le forum Macros et VBA Excel
    Réponses: 4
    Dernier message: 24/08/2010, 19h40
  3. Encodage du contenu du mail avec IMAP
    Par cyreel dans le forum Bibliothèques et frameworks
    Réponses: 1
    Dernier message: 25/09/2009, 10h19
  4. [JavaMail] Extraction de contenu de mail
    Par MackZ dans le forum API standards et tierces
    Réponses: 4
    Dernier message: 22/03/2009, 11h13
  5. Envoi mail avec date postérieur
    Par imanoual dans le forum API standards et tierces
    Réponses: 2
    Dernier message: 25/03/2008, 15h32

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo