Bonjour,
J'ai besoin de créer une macro dans Outlook qui me permet d'archiver mes messages, j'ai pour cela un pseudo cahier des charges et ai commencé à récupérer à droite à gauche divers bouts de code pour dégrossir le projet. (ça fait longtemps que j'ai pas fait de programmation et j'ai vraiment du mal à m'y remettre)
J'ai un serveur avec une arborescence :
X:\Affaire\XXXX_NomAffaire_Client\Emails
J'ai Outlook 2010 et un dossier qui s'appelle "XXXX_NomAffaire"
> Je déplace mes messages dans leurs dossiers respectifs Outlook après réception
Je voudrais pouvoir sélectionner mon dossier "XXXX_NomAffaire" et lancer ma macro pour :
- Qu'elle cherche dans x:\ le dit dossier "XXXX_NomAffaire" et enregistre le chemin dans une variable
- Enregistre dans cette destination tous les messages du dossier au format "XXXX_NomAffaire"_"Date"_"Expéditeur"_"Sujet" (avec une limite de caractère, mais je ne sait pas combien il faudrait mettre)
> En cas de doublon, incrémenter (1)
- Demande la suppression des messages dans le dossier Outlook une fois exportés
J'ai récupéré et modifié :
Ce morceau de code me permet de formater presque correctement le nom du message enregistre ma sélection dans c:\mail\
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) Dim MonApply As Outlook.Application Dim Expl As Explorer Dim myNameSpace As NameSpace Dim myFolder As MAPIFolder Dim myItems As Items Dim xi As Integer Set MonApply = Outlook.Application Set Expl = ActiveExplorer Set myNameSpace = MonApply.GetNamespace("MAPI") If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem 'Nom du fichier qui sera créé NomExport = objCurrentMessage.CreationTime & " " & objCurrentMessage.SenderName & "_" & objCurrentMessage.Subject 'Ici on défini le répertoire où l'enregistrer repertoire = "c:\mail\" 'Ici on supprime les caractères non autorisé dans les noms de fichiers PathNomExport = repertoire & Expl & "-" & 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 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
Problèmes :
- Je ne sais pas comment prendre le problème de la recherche du dossier sur le serveur
- Je ne sais pas comment dire enregistrer "le contenu complet du dossier" et non "ma sélection de message"
- l'attribut objCurrentMessage.CreationTime me colle l'heure ... je n'arrive pas à trouver celui qui me formaterais la date "AnnéeMoisJour"
- Je pense que la fonction vidage est secondaire à cet étape de developpement
Si une âme charitable sait me venir en aide ... je continue à gratter de mon coté ^^
Merci
Partager