Discussion :

[Murmure]

Bonjour à tous.

Je suis dans le cas de figure suivant : Ma société a changé de nom; de toto elle s'appelle désormais totobibi.

De nouvelles adresses mail XXX@totobibi.fr ont été créées.
Cependant les commerciaux et d'autres personnes continuent de recevoir des mails sur XXX@toto.fr donc ils ont 2 comptes sur Outlook (un en toto.fr et un en totobibi.fr).

Mon responsable souhaite supprimer les toto.fr au 31 Decembre et il veut donc que je programme un script qui ;

- Créé un dossier XXX@toto.fr (facile j'ai fait une box où machintruc rentre son nom).

- Les mails reçus sur le compte @toto.fr soient automatiquement classés à leur réception dans le dossier XXX@toto.fr

C'est là mon problème : pas moyen de savoir si le mail reçu a été envoyé vers le compte toto.fr (donc action) ou le compte totobibi.fr (donc rien) ?

Avez vous une idée pour m'aider svp ?

NOTE : vu le nombre de personnes concernées, créer une règle à la main sur chaque poste est exclu.

[Oliv-]

Salut,
il faut utiliser une dll spécifique REDEMPTION.

[Murmure]

Salut,
il faut utiliser une dll spécifique REDEMPTION.

Merci, tu peux m'en dire plus s'il te plait ?

[Murmure]

J'arrive à scanner un dossier pour récupérer les sujets des mails, mais je n'arrive pas à en récuperer l'adresse du destinataire, même avec Redemption, Quelqu'un saurait m'aider svp ?

Ce script doit marcher pour la fin de semaine prochaine et je désespère, je sens que je vais me tapper la création de règle sur les 80 boites mail à traiter ...

[Oliv-]

SAlut,
Tu as donc trouvé REDEMPTION

voic un ex:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
Sub testrdo()
 
Set SessionRDO = CreateObject("Redemption.RDOSession")
SessionRDO.Logon
Set Inbox = SessionRDO.GetDefaultFolder(olFolderInbox)
On Error Resume Next
For Each msg In Inbox.Items
 
Debug.Print (msg.Account.Name)
MsgBox msg.Account.Name
Next
 
End Sub

[Murmure]

Sympa ton script mais il n'y a pas de convention de nommage des comptes dans ma boite donc je ne peux pas m'appuyer sur le nom de l'account pour pouvoir trier les mails ...

[Oliv-]

Eh bien tu peux utiliser d'autres propriétés de ACCOUNT non ?
http://www.dimastr.com/redemption/rdo/RDOAccount.htm

[Murmure]

En utilisant Smtpaddress a la place de name ça devrait le faire ... Merci, je teste et je reviens pleurer si ça marche pas !

MERCI

[Murmure]

Bon,

j'arrive bien grace a "msg.Account.POP3_Server" à déterminer les messages qui seront à déplacer.

Le problème suivant est comment les déplacer ?
Y'a t'il un "msg.Move" possible ?

Merci ...

[Murmure]

je ne trouve pas comment faire un move de mes messages avec Redemption, j'ai l'impression que je peux seulement consulter des propriétés ... Je me trompe ? Comment procéder ?

J'ai éssayé :

Inbox.Items.Move ("dossier de classement")

Mais vraisemblablement ça ne fonctionne pas car mes messages ne bougent pas ...

[Oliv-]

Redemption permet de faire plus que le com OUTLOOK, tu as sans doute oublié de lui mettre un paramétre.

Code :

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

Msg.Move(DestFolder)

Tu peux aussi utiliser des fonctions outlook et REDEMPTION dans le même code.

[Murmure]

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
Sub ScanInbox()
 
    Dim ServeurPop As String
    Set SessionRDO = CreateObject("Redemption.RDOSession")
    SessionRDO.Logon
    Set Inbox = SessionRDO.GetDefaultFolder(olFolderInbox)
    On Error Resume Next
        For Each Msg In Inbox.Items
            Debug.Print (Msg.Account.POP3_Server)
            ServeurPop = Msg.Account.POP3_Server
            If ServeurPop = "pop.magic.fr" Then
                Msg.Move (test)
                MsgBox ("message trouvé et déplacé dans le dossier test")
            End If
        Next
End Sub

Voilà mon code actuellement, mais même si je n'ai pas d'erreur, les messages concernés ne sont pas déplacés (alors que j'ai bien la MsgBox correspondante pour chaque message trouvé).

Je sais que je suis une quiche mais je suis obligé d'apprendre en même temps que je fais ... Et j'avoue que je ne suis pas à l'aise avec la programmation orientée objet (ce dont tu as déjà du te rendre compte), c'est un peu de la bidouille copier/coller mais j'ai pas le choix ...

[Oliv-]

En fait met un ' devant on error ... comme cela tes messages d'erreurs vont remonter une fois ton code correct tu peux enlever le commentaire sur cette ligne.

c'est parce que test n'est pas défini et ne représente pas un dossier.
essaye avec

Code :

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

Msg.Move Inbox.folders("test")

le sous dossier test doit exister

[Murmure]

En fait met un ' devant on error ... comme cela tes messages d'erreurs vont remonter une fois ton code correct tu peux enlever le commentaire sur cette ligne.

c'est parce que test n'est pas défini et ne représente pas un dossier.
essaye avec

Code :

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

Msg.Move Inbox.folders("test")

le sous dossier test doit exister

Oui effectivement merci bien ça fonctionne parfaitement, merci pour ton aide sans toi j'étais dans la merde.

L'étape suivante est que le script doit checker à chaque arrivée de mail si c'est un mail correspondant à

Code :

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

Msg.Account.POP3_Server = "pop.magic.fr"

, je vais éssayer de transformer ma fonction tout seul, si j'ai un soucis (ce qui vu ma nullité en VBA ne devrait pas tarder, je me permettrais de venir te solliciter encore

[Murmure]

Je comptais placer mon script dans une règle "à l'arrivée de chaque nouveau message" mais par quoi remplacer

Code :

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

For Each Msg In Inbox.Items

afin que mon test

Code :

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

1
2
3
If ServeurPop = "pop.magic.fr" Then
   Msg.Move Inbox.Folders(adressegeta)
End If

Ne s'éxécute pas sur toute la boîte de réception à chaque arrivée de nouveau mail ? (ce qui va beaucoup trop ralentir Outlook)

[Oliv-]

Essaye avec le code suivant la premiere macro sert à simuler la regle :

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
Private Sub lance_testrdo()
Dim StrID As Outlook.MailItem
Set StrID = ActiveInspector.CurrentItem
Call testrdo(StrID)
End Sub
 
Sub testrdo(StrID As Outlook.MailItem)
 
    Set SessionRDO = CreateObject("Redemption.RDOSession")
    'SessionRDO.Logon
    SessionRDO.MAPIOBJECT = Application.Session.MAPIOBJECT
    Set Inbox = SessionRDO.GetDefaultFolder(olFolderInbox)
    Dim msg As Object
 
    Set msg = SessionRDO.GetMessageFromID(StrID.EntryID)
    ServeurPop = msg.Account.POP3_Server
 
    'MsgBox msg.Account.Name
    If ServeurPop = "pop.magic.fr" Then
    msg.Move Inbox.Folders(adressegeta)
    End If
 
    Set SessionRDO = Nothing
    Set Inbox = Nothing
    Set msg = Nothing
 
End Sub

[Murmure]

Merci pour ton aide, j'ai enfin ce que je veux. je mets le code si ça peut aider quelqu'un :
Pour le lancer je créée une règle qui lance TestNewMailGetaFR. Le script se lance à chaque arrivée de message

La première chose que fait le script c'est vérifier si il éxiste un fichier txt dans system32. Si ce fichier éxiste c'est que la Boite de réception a déjà été scannée et le sous dossier créé --> le script vérifie alors si le message vient de l'ancienne adresse --> si c'est le cas il le stocke dans le sous dossier adéquat.

Si le fichier txt n'éxiste pas, le script vérifie si le sous dossier de classement éxiste --> si c'est pas le cas il le crée. Ensuite il lance un scan de la boite de réception (mais volontairement pas dans les sous dossiers pour ne pas mettre en l'air les classements qu'ont déjà pu faire mes utilisateurs. Quand il trouve un message correspondant à l'ancienne adresse il le stocke dans le bon dossier. Une fois son scan fini le script crée le fichier dans system32 (qui sert d'indicateur pour éviter qu'il scanne entièrement inbox à chaque nouveau mail reçu ce qui serait très lent).

Il est à noter que pour obtenir l'ancienne adresse je ruse : l'account par défaut de mes users est TOTO@getalinks.fr et mes anciennes adresses seront toutes du type TOTO@geta.fr donc je procède juste à un remplacement de chaîne ; getalinks.fr devient geta.fr, ça n'aurait pas été possible de cette façon si les adresses avaient été différentes.

De même que mon script ne se base pas sur l'adresse mais sur le serveur POP3 pour trier les mails ; en effet le serveur utilisé pour les anciennes adresses n'est pas le même que pour les nouvelles, sans ça ça aurait été une difficulté de plus.

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
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
Sub TestNewMailGetaFR(StrID As Outlook.MailItem)
    Dim ServeurPop As String
    Dim FichierFlag As String
    Set SessionRDO = CreateObject("Redemption.RDOSession")
    'SessionRDO.Logon
    SessionRDO.MAPIOBJECT = Application.Session.MAPIOBJECT
    Set Inbox = SessionRDO.GetDefaultFolder(olFolderInbox)
    Dim msg As Object
    Dim adressegeta As String
    Call Createadressegeta(adressegeta)
    FichierFlag = "C:\WINDOWS\system32\" & "Migration_Mail_" & adressegeta & ".txt"
    Set msg = SessionRDO.GetMessageFromID(StrID.EntryID)
    ServeurPop = msg.Account.POP3_Server
 
    If Dir(FichierFlag) = "" Then
        Call Lanceur_Scan_de_la_Boite
        Call CreateFichierTXT
    End If
 
    'MsgBox msg.Account.Name
    If ServeurPop = "pop.magic.fr" Then
    msg.Move Inbox.Folders(adressegeta)
    End If
 
    Set SessionRDO = Nothing
    Set Inbox = Nothing
    Set msg = Nothing
 
End Sub
Sub Lanceur_Scan_de_la_Boite()
    Dim Dossiergetaexiste As Boolean
    Dim adressegeta As String
    Dim myOlApp As Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim fld As Outlook.MAPIFolder
 
    Set myOlApp = CreateObject("Outlook.Application")
    Set myNameSpace = myOlApp.GetNamespace("MAPI")
    Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
 
    Call Createadressegeta(adressegeta)
 
    For Each fld In myFolder.Folders
            If fld.Name = adressegeta Then
                Dossiergetaexiste = True
            End If
    Next
    If Dossiergetaexiste = True Then
        Call ScanInbox
    Else
        Call CreateDossier
        Call ScanInbox
    End If
End Sub
Sub Createadressegeta(adressegeta As String)
    Dim CU
    Dim adressegetalinks As String
    Set CU = CreateObject("Redemption.SafeCurrentUser")
    adressegetalinks = CU.Address
    adressegeta = Replace(adressegetalinks, "getalinks.fr", "geta.fr")
End Sub
Sub CreateDossier()
    Dim monOutlook As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim dossier As MAPIFolder
    Dim myNewFolder As MAPIFolder
    Dim adressegeta As String
    Call Createadressegeta(adressegeta)
    Set myNameSpace = monOutlook.GetNamespace("MAPI")
    Set dossier = myNameSpace.Folders("Dossiers personnels").Folders("Boîte de réception")
    Set myNewFolder = dossier.Folders.Add(adressegeta)
 
End Sub
Sub ScanInbox()
    Dim ServeurPop As String
    Set SessionRDO = CreateObject("Redemption.RDOSession")
    SessionRDO.Logon
    Set Inbox = SessionRDO.GetDefaultFolder(olFolderInbox)
    Dim adressegeta As String
    Call Createadressegeta(adressegeta)
    On Error Resume Next
        For Each msg In Inbox.Items
            ServeurPop = msg.Account.POP3_Server
            If ServeurPop = "pop.magic.fr" Then
                msg.Move Inbox.Folders(adressegeta)
            End If
        Next
End Sub
Sub CreateFichierTXT()
    Dim FichierEtEmplacement As String
    Dim adressegeta As String
    Call Createadressegeta(adressegeta)
    FichierEtEmplacement = "C:\WINDOWS\system32\" & "Migration_Mail_" & adressegeta & ".txt"
    Open FichierEtEmplacement For Output Shared As #1
    Print #1, adressegeta & " Dernier scan complet d'Inbox" & " le " & Date & " à " & Time; ""
    Close #1
End Sub

Encore Merci Oliv- c'est vraiment sympa ... Sans toi je n'y serai pas arrivé.

Maintenant il ne me reste plus qu'à déployer le script sur chaque PC : Quelqu'un a une idée pour le déployer simplement (sans faire un copier coller sur chaque poste). ?

[Oliv-]

Salut,
Pour déployer le script tu dois copier sur chaque poste dans %appdata%
les fichiers VbaProject.OTM et outcmd.dat (barres d'outils)

tu peux utiliser un script d'ouverture de session si tu es dans un DOMAINE.

Code :

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

1
2
copy %logonserver%\netlogon\util\VbaProject.OTM "%APPDATA%\Microsoft\Outlook"
copy %logonserver%\netlogon\util\outcmd.dat "%APPDATA%\Microsoft\Outlook" /y

Par contre si tu utilises redemption il faut l'installer sur chaque poste:

Code :

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

cscript %logonserver%\netlogon\util\redemption\redemption.vbs

voici le code que j'ai utilisé, par contre l'utilisateur doit intervenir, si tu as une autre méthode ca m'intéresse.

Code :

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

1
2
3
4
5
6
7
8
9
'REDEMPTION.vbs
On Error Resume Next
Set EXISTE = CreateObject("Redemption.RDOsession")
If EXISTE Is Nothing Then
MsgBox "Cochez 'I AGREE' puis cliquez sur OK", , "Instruction fenêtre Outlook Redemption suivante"
Set wshShell = WScript.CreateObject ("WSCript.shell")
wshshell.run "regsvr32 /s %logonserver%\netlogon\util\redemption\redemption.dll", 1, True
set wshshell = nothing
End I

[Murmure]

j'ai éssayé ton script mais comment faire une fois installé par ce moyen pour qu'Outlook utilise Redemtion ; lorsqu'on passe par l'installeur .exe normal les macros marchent direct alors que là j'ai une erreur sur le premier RDO qu'il trouve ... une idée ?

[Oliv-]

Bonjour,
C'est quoi l'erreur ? peut être lié à l'emplacement de la dll ? as tu référencé dans OUTLOOK Redemption ? Si oui c'est parce qu'il n'est pas (la dll) au même endroit sur ton poste et autres les postes, mais tu n'a pas besoin de le référncer tu es en "late binding"