Discussion :

[lilp1]

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.

[lilp1]

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

[Oliv-]

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

[lilp1]

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.

[lilp1]

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

[Oliv-]

IL FAUT UTILISER

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Format(MADate, "YYYYMMDD-hhmm")

[lilp1]

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

[slambill]

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 ?