[VBA - Outlook] Comment récuperer adresse mail destinataire ?

[Oliv-]

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

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.

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.

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:

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.

'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"

[Murmure]

Envoyé par 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"

Non, comment tu le références ?

[Oliv-]

Salut,
regarde l'aide de Morgan http://dolphy35.developpez.com/artic...ok/vba/#LIII-G,

l'ajout d'une référence est utile pour avoir la saisie assistée, et les constantes, dans ton cas je le redis ce n'est pas nécessaire.