Discussion :

[romv34]

Bonjour à tous,

je souhaite créer une macro pour classer mes mails. Mon niveau est grand débutant en VBA avec excel, et nul avec outlook...

Le but à terme:

Création d'un dossier avec les mails dont les contacts ne font pas partie de ma société ( fournisseurs ) à partir du dossier actif

Classer les mails du dossier actif dont les contacts font partie de ma société en fonction des champs personnalisés des contacts. Dans ma société, nous avons pour chaque contacts un champ "service" et un champ "fonction" qui sont mis à jour (via exchange si j'ai bien compris).

Je souhaite créer une arborescence : Service/fonction/

Pour commencer je souhaiterais savoir comment effectuer la séparation des mails des contacts de ma société (@tartanpion.com) et des autres.

Je ne souhaite pas de solution sur un plateau, je veux comprendre ce que je fais, mais dans outlook il n'y a pas d'enregistreur de macro pour apprendre en tâtonnant ...

Merci pour votre aide, vos explications, et conseils,

Romv

[romv34]

Bonjour,

J'ai trouvé le code ci-dessous sur www.slipstick.com:

Je vais partir de ce code pour faire mon premier tri.

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
 
Sub MoveAgedMail()
  Dim objOutlook As Outlook.Application
  Dim objNamespace As Outlook.NameSpace
  Dim objSourceFolder As Outlook.MAPIFolder
  Dim objDestFolder As Outlook.MAPIFolder
  Dim objVariant As Variant
  Dim lngMovedItems As Long
  Dim intCount As Integer
  Dim intDateDiff As Integer
  Dim strDestFolder As String
 
  Set objOutlook = Application
  Set objNamespace = objOutlook.GetNamespace("MAPI")
  Set objSourceFolder = objNamespace.GetDefaultFolder(olFolderInbox)
 
  For intCount = objSourceFolder.Items.Count To 1 Step -1
    Set objVariant = objSourceFolder.Items.Item(intCount)
    DoEvents
 
    If objVariant.Class = olMail Then
       intDateDiff = DateDiff("d", objVariant.SentOn, Now)
        ' I'm using 40 days, adjust as needed.
       If intDateDiff > 40 Then
       ' use your datafile name and each folder in the path
       ' the example uses an email address because Outlook 2010
       ' uses email addresses for datafile names
sSenderName = objVariant.SentOnBehalfOfName
 
If sSenderName = ";" Then
  sSenderName = objVariant.SenderName
 
End If
 
On Error Resume Next
 
Set objDestFolder = objSourceFolder.Folders(sSenderName)
 
If objDestFolder Is Nothing Then
    Set objDestFolder = objSourceFolder.Folders.Add(sSenderName)
       End If
            objVariant.Move objDestFolder
            'count the # of items moved
            lngMovedItems = lngMovedItems + 1
            Set objDestFolder = Nothing
        End If
    End If
  Next
 
' Display the number of items that were moved.
  MsgBox "Moved " & lngMovedItems & " messages(s)."
 
  Set objOutlook = Nothing
  Set objNamespace = Nothing
  Set objSourceFolder = Nothing
 
End Sub

[romv34]

Bonjour,

J'ai un peu avancé, mais là je bloque ....

J'ai remarqué que pour les contacts de ma société, le obj.SenderEmailAddress me renvoi une chaine qui ne correspond pas à une adresse mail, je pense que cela renvoi des données exchange ?
Par contre sur les mails de mes fournisseurs, cela renvoi bien l'adresse mail.

Cela me permet de faire le tri en testant si la chaine de caractère contient arobase.

Si mon dossier fournisseur existe, le déplacement fonctionne, si il n'existe pas et que j'essai de le créer j'ai un message (erreur d'exécution '-2147221233 (8004010f)': Echec de l'opération. impossible de trouver un objet) , pour l'instant je ne trouve pas encore pourquoi.

voici où j'en suis, si vous avez des commentaires, ou une manière plus simplifiée...

Merci;

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
Public Sub separation()
 
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim testarro As Integer
 
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim Email As String
Dim objInbox  As Outlook.MAPIFolder
 
Dim monOutlook As New Outlook.Application
Dim ns As NameSpace
 
 
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
 
 
 
For Each obj In Selection
    Set objVariant = obj
    Email = obj.SenderEmailAddress
    testarro = InStr(Email, "@")
        If testarro > 0 Then
            Set objDestFolder = objSourceFolder.Folders("fournisseurs")
            On Error Resume Next
                 If objDestFolder Is Nothing Then
                       Set ns = monOutlook.GetNamespace("MAPI")
                       Set objDestFolder = objSourceFolder.Folders.Add("fournisseurs")
                  End If
            objVariant.Move objDestFolder
        End If
    Err.Clear
Next
 
 
 
End Sub

[romv34]

Erreur trouvée...

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
Public Sub separation()
 
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim testarro As Integer
 
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim Email As String
Dim objInbox  As Outlook.MAPIFolder
Dim boltest As Boolean
 
Dim monOutlook As New Outlook.Application
Dim ns As NameSpace
Dim strnomdedossier As String
 
 
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
strnomdedossier = "fournisseurs"
On Error Resume Next
 
Set objDestFolder = objSourceFolder.Folders(strnomdedossier)
 
For Each obj In Selection
    Set objVariant = obj
    Email = obj.SenderEmailAddress
    testarro = InStr(Email, "@")
        If testarro > 0 Then
                  If objDestFolder Is Nothing Then
                       Set ns = monOutlook.GetNamespace("MAPI")
                       Set objDestFolder = objSourceFolder.Folders.Add(strnomdedossier)
                  End If
            objVariant.Move objDestFolder
        End If
    Err.Clear
Next
 
 
 
End Sub

[Oliv-]

Bonjour Romain,
c'est très bien de chercher et de trouver des solutions sois même.

Par contre tu as sans doute une erreur là:

Code :

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

Set objSourceFolder = currentExplorer.CurrentFolder

où là

Code :

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

Set objDestFolder = objSourceFolder.Folders(strnomdedossier)

Je m'explique, en partant du dossier en cours et tu vas classer dans un sous dossier de celui-ci.
donc à moins de ne lancer la macro que du même dossier tu auras plein de sous dossiers correspondant à tes expéditeurs.

tu devrais changer ainsi, à moins que je n'ai pas compris la finalité

Code :

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

Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).Folders(strnomdedossier)

pour obj.SenderEmailAddress cela dépend de
.SenderEmailType : "EX" : String
si c'est EX c'est effectivement une adresse EXCHANGE
et je ne suis pas sûr que l'absence d'arobase signifie que c'est ton domaine !??

Avec cela tu devrais obtenir tes éléments Service/fonction et ta confirmation que c'est bien une personne de ton domaine.

Code :

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

1
2
3
4
5
6
7
8
9
10
Sub test_sender_exchange()
    Set OITEM = ActiveInspector.CurrentItem 'désigne l'élément actif càd le mail le contact ou rdv...
    Dim oEU As Outlook.ExchangeUser
    Set oEU = OITEM.Sender.GetExchangeUser
 
    MsgBox oEU.PrimarySmtpAddress
    MsgBox oEU.Department
    oEU.Details
 
End Sub

regarde là pour les propriétés http://msdn.microsoft.com/fr-fr/libr...ffice.15).aspx


et voici pour obtenir l'adresse mail à partir d'un "recipient"

Code :

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

1
2
3
4
5
6
7
8
9
10
Function GetSMTPAddressForRecipient(recip As Outlook.Recipient) As String
'Dim recip As Outlook.Recipient
    Dim pa As Outlook.PropertyAccessor
    Const PR_SMTP_ADDRESS As String = _
          "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
    Set pa = recip.PropertyAccessor
Debug.Print recip.Name & " SMTP=" _
          & pa.GetProperty(PR_SMTP_ADDRESS)
    GetSMTPAddressForRecipient = pa.GetProperty(PR_SMTP_ADDRESS)
End Function

[romv34]

Bonjour Oliv-,

Merci pour les infos, pour ce qui est du dossier, effectivement je n'ai qu'un dossier " A ranger" a partir du quel je lance ma macro ( un pst en fait), c'est les mails traités.

Pour être plus précis, j'ai un pst par "service", et un pst par année d'envoi.

Pour le reste je teste et posterais la suite des événements,

Merci encore

[romv34]

Re- Bonjour,


Comme ça je récupère ce dont j'ai besoin :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Sub test_sender_exchange()
 
    Dim OITEM As Variant
    Set OITEM = ActiveInspector.CurrentItem 'désigne l'élément actif càd le mail le contact ou rdv...
    Dim oEU As Outlook.ExchangeUser
    Set oEU = OITEM.Sender.GetExchangeUser
 
    MsgBox oEU.PrimarySmtpAddress & " " & oEU.Department & " " & oEU.JobTitle
 
 
 
End Sub

Reste plus qu' à définir que le departement est un .pst, et le jobtitle un dossier de ce pst. Je classerais dedans par nom et le tour sera joué...

Il faudra aussi que j'ouvre le pst si il est fermé et que je le créé si il n’existe pas, mais quand j'en serais là ce ne sera qu'un détail....

Je ferais surement un pst par année...

Enfin, on verra,

Merci,

je poste quand j'avance, et quand j'aurais tester pour le recipient, (dès que j'aurais compris ce que cela veut dire....)

[patrice084]

Bonjour à tous,

je souhaite créer une macro pour classer mes mails. Mon niveau est grand débutant en VBA avec excel, et nul avec outlook...

Est-ce que l'utilisation des règles ne permettraient pas plus simplement de gérer vos courriers entrants ?

[romv34]

Bonjour Patrice,

Pour les règles, je ne sais pas, j'ai des centaines de contacts et je veux lancer ma macro uniquement sur les mails "traités".

sinon, j'ai avancé.

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
62
63
64
65
66
67
68
69
70
71
72
73
74
Option Explicit
 
Public Sub testfinal()
 
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim domaine As String
Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer
Dim intDateDiff As Integer
Dim strDestFolder As String
Dim Email As String
Dim objInbox  As Outlook.MAPIFolder
Dim boltest As Boolean
Dim monOutlook As New Outlook.Application
Dim ns As NameSpace
Dim strnomdedossier As String
Dim strdossierservice As String
Dim strdossierjobtitle As String
Dim OITEM As Variant
Dim oEU As Outlook.ExchangeUser
Dim testarro As Integer
Dim objDestsubFolder As Outlook.MAPIFolder
 
 
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
strnomdedossier = "fournisseurs"
On Error Resume Next
 
Set objDestFolder = objSourceFolder.Folders(strnomdedossier)
 
For Each obj In Selection
    Set objVariant = obj
    Email = obj.SenderEmailAddress
    'domaine = Right(Email, 9)
    testarro = InStr(Email, "@")
        If testarro > 0 Then
                  If objDestFolder Is Nothing Then
                       Set ns = monOutlook.GetNamespace("MAPI")
                       Set objDestFolder = objSourceFolder.Folders.Add(strnomdedossier)
                  End If
                objVariant.Move objDestFolder
 
        End If
 
        If testarro = 0 Then
                Set OITEM = obj 'désigne l'élément actif càd le mail le contact ou rdv...
                Set oEU = OITEM.Sender.GetExchangeUser
                strdossierservice = oEU.Department
                strdossierjobtitle = oEU.JobTitle
                Set ns = monOutlook.GetNamespace("MAPI")
                Set objDestFolder = objSourceFolder.Folders.Add(strdossierservice)
                Set objDestsubFolder = objDestFolder.Folders.Add(strdossierjobtitle)
 
                objVariant.Move objDestsubFolder
 
        End If
 
    Err.Clear
Next
 
 
 
End Sub

Avec ça je déplace bien mes mails vers des dossiers et sous dossiers, ça me suffirait presque....

Comment faire pour chercher dans les différents dossier (ou pst) le nom du service?

Merci

[Oliv-]

Bonjour,
Cela me semble très compliqué comme classement !
Un pst, soit mais du coup il ne sera disponible que sur le PC en question, fini de l'avantage de exchange, et attention aux crashs de disque dur.

Code :

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

1
2
3
4
5
6
7
 
Set objNamespace = Application.GetNamespace("MAPI")
 
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox) ' = boite de reception
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).parent  '= ta bal
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).parent.parent '=  la racine d'outlook
Set objDestFolder = objNamespace.GetDefaultFolder(olFolderInbox).parent.parent.Folders '=les différent comptes ou PST

[romv34]

Bonjour,

Merci je vais tester.

C'est vrai que c'est compliqué...

Pour les PST et exchange, en fait on est limité sur la capacité du serveur (1GO), et les mails de plus de 1 mois sont supprimés...

Une dernière question avant que je me replonge dans le code, est ce que vous savez comment on fait pour que lorsque l'on fait glisser des dossiers, si un dossier du même nom existe ils soient fusionnés et non renommé avec un 1 à la fin ?

Merci,

[romv34]

Bonjour à tous,

J'ai terminé ma macro, j'ai pris exemple sur cette macro pour le déplacement dans les pst.

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
62
63
64
65
66
67
68
Option Explicit
 
Public Sub classement()
 
Dim objOutlook As Outlook.Application
Dim objNamespace As Outlook.NameSpace
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object
Dim strdomaine As String
Dim objVariant As Variant
Dim strEmail As String
Dim strdossierservice As String
Dim strdossierjobtitle As String
Dim varOITEM As Variant
Dim oEU As Outlook.ExchangeUser
Dim inttestarro As Integer
Dim objDestsubFolder As Outlook.MAPIFolder
Dim ns As Outlook.NameSpace
Dim objMoveToFolderInPST As Outlook.MAPIFolder
 
Set objOutlook = Application
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set ns = Application.GetNamespace("MAPI")
 
On Error Resume Next
 
For Each obj In Selection
    Set objVariant = obj
    strEmail = obj.SenderEmailAddress
    strdomaine = Right(strEmail, 9) ' mon nom de domaine comporte 9 lettres
    inttestarro = InStr(strEmail, "@")
        If inttestarro > 0 Then
                    If strdomaine = "12345.com" Then GoTo 1 ' remplacé par mon nom de domaine
                        Set objMoveToFolderInPST = ns.Folders("fournisseur").Folders("ARANGER")
                        objVariant.Move objMoveToFolderInPST
 
        End If
 
        If inttestarro = 0 Then
                Set varOITEM = obj 'désigne l'élément actif càd le mail le contact ou rdv...
                Set oEU = varOITEM.Sender.GetExchangeUser
                strdossierservice = oEU.Department
                strdossierjobtitle = oEU.JobTitle
                Set objDestsubFolder = ns.Folders(strdossierservice).Folders.Add(strdossierjobtitle)
                Set objMoveToFolderInPST = ns.Folders(strdossierservice).Folders(strdossierjobtitle)
                If objMoveToFolderInPST = "" Then
 
                    MsgBox ("Attention le Fichier d'archive " & strdossierservice & " n'éxiste pas .")
 
                    GoTo 2
 
                End If
 
                objVariant.Move objMoveToFolderInPST
                strdossierservice = ""
                strdossierjobtitle = ""
 
        End If
 
1
    Err.Clear
Next
 
2
End Sub

Elle est surement perfectible, mais elle fait le boulot !

Merci pour votre aide,

Rom