Bonjour à tous et merci d'avance pour votre aide,
je souhaite déplacer le mail actif de la boite de reception dans une archive .pst
la macro ci dessous me permet de faire ce déplacement, mais dans un sous repertoire de la boite de reception et pas une archive pst...
/////////////////////////////////////////////////////////////////////////////////////////////
Sub RécupInfoMailouvertPourFichierNouvelArrivantEtDeplacementRepNewArrivant()
Dim vnom As String
Dim Exp As Explorer
Dim Itm As MailItem
Dim MonMail As String
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder 'dossier de destination pour l'archivage
Dim Ns As Outlook.Namespace
'Définition objet
Set Exp = ActiveExplorer
Set sel = Exp.Selection
Set olApp = CreateObject("Outlook.Application")
Set Ns = olApp.GetNamespace("MAPI")
'recup info "boite de reception"
Set myInbox = Ns.GetDefaultFolder(olFolderInbox)
'recup nom du repertoire dans lequel on veut sauvegarder notre mail
Set myDestFolder = myInbox.Folders("nouveaux arrivants")
'Boucle de récupération de l'objet des messages sélectionnés
For Each Itm In sel
vnom = Left(Itm.Subject, InStr(InStr(1, Itm.Subject, " ", vbTextCompare) + 1, Itm.Subject, " ", vbTextCompare) - 2)
vobjet = Itm.Subject
'MonMail = Sel.Subject
Itm.Move myDestFolder
Next Itm
' Nettoyage des objets
Set Itm = Nothing
Set sel = Nothing
Set Exp = Nothing
End Sub
/////////////////////////////////////////////////////////////////////////////////////////////
J'ai trouvé par ailleurs le moyen de selectionner un .pst parmis tous les repertoires de la boite outlook :
/////////////////////////////////////////////////////////////////////////////////////////////
Sub travaillerSurRepertoirePstNouveauxArrivants()
Dim olApp As Outlook.Application, flagToClose As Boolean
'ouvrir Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
flagToClose = olApp Is Nothing
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
If olApp Is Nothing Then Stop 'si on s'arrête ici, c'est qu'on n'a pas réussi à ouvrir Outlook
On Error GoTo 0
Dim curFold As Outlook.Folder
Dim rgExp As VBScript_RegExp_55.RegExp
Set rgExp = CreateObject("VBScript.RegExp")
rgExp.Global = True
For Each curFold In olApp.Session.Folders
If curFold.Name = "nouveaux arrivants" Then
MsgBox "CA MARCHE!"
End If
Next curFold
If flagToClose Then olApp.Quit
EndFunction:
Application.StatusBar = False
End Sub
/////////////////////////////////////////////////////////////////////////////////////////////
Comment puis je déclarer "myDestFolder" (=mon repertoire .pst)dans la premiere macro pour deplacer un mail dedans?..
ex qui ne marche pas à partir des infos de la 2eme macro :
Dim myDestFolder As olApp.Session.Folders 'dossier de destination pour l'archivage
Set myDestFolder = "nouveaux arrivants"
Apres beaucoup d'essais, je ne m'en sors pas...
Merci beaucoup pour vos retours!
Cordialement.
Frédéric
je souhaite déplacer le mail actif de la boite de reception dans une archive .pst
la macro ci dessous me permet de faire ce déplacement, mais dans un sous repertoire de la boite de reception et pas une archive pst...
/////////////////////////////////////////////////////////////////////////////////////////////
Sub RécupInfoMailouvertPourFichierNouvelArrivantEtDeplacementRepNewArrivant()
Dim vnom As String
Dim Exp As Explorer
Dim Itm As MailItem
Dim MonMail As String
Dim myInbox As Outlook.MAPIFolder
Dim myDestFolder As Outlook.MAPIFolder 'dossier de destination pour l'archivage
Dim Ns As Outlook.Namespace
'Définition objet
Set Exp = ActiveExplorer
Set sel = Exp.Selection
Set olApp = CreateObject("Outlook.Application")
Set Ns = olApp.GetNamespace("MAPI")
'recup info "boite de reception"
Set myInbox = Ns.GetDefaultFolder(olFolderInbox)
'recup nom du repertoire dans lequel on veut sauvegarder notre mail
Set myDestFolder = myInbox.Folders("nouveaux arrivants")
'Boucle de récupération de l'objet des messages sélectionnés
For Each Itm In sel
vnom = Left(Itm.Subject, InStr(InStr(1, Itm.Subject, " ", vbTextCompare) + 1, Itm.Subject, " ", vbTextCompare) - 2)
vobjet = Itm.Subject
'MonMail = Sel.Subject
Itm.Move myDestFolder
Next Itm
' Nettoyage des objets
Set Itm = Nothing
Set sel = Nothing
Set Exp = Nothing
End Sub
/////////////////////////////////////////////////////////////////////////////////////////////
J'ai trouvé par ailleurs le moyen de selectionner un .pst parmis tous les repertoires de la boite outlook :
/////////////////////////////////////////////////////////////////////////////////////////////
Sub travaillerSurRepertoirePstNouveauxArrivants()
Dim olApp As Outlook.Application, flagToClose As Boolean
'ouvrir Outlook
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
flagToClose = olApp Is Nothing
If olApp Is Nothing Then Set olApp = CreateObject("Outlook.Application")
If olApp Is Nothing Then Stop 'si on s'arrête ici, c'est qu'on n'a pas réussi à ouvrir Outlook
On Error GoTo 0
Dim curFold As Outlook.Folder
Dim rgExp As VBScript_RegExp_55.RegExp
Set rgExp = CreateObject("VBScript.RegExp")
rgExp.Global = True
For Each curFold In olApp.Session.Folders
If curFold.Name = "nouveaux arrivants" Then
MsgBox "CA MARCHE!"
End If
Next curFold
If flagToClose Then olApp.Quit
EndFunction:
Application.StatusBar = False
End Sub
/////////////////////////////////////////////////////////////////////////////////////////////
Comment puis je déclarer "myDestFolder" (=mon repertoire .pst)dans la premiere macro pour deplacer un mail dedans?..
ex qui ne marche pas à partir des infos de la 2eme macro :
Dim myDestFolder As olApp.Session.Folders 'dossier de destination pour l'archivage
Set myDestFolder = "nouveaux arrivants"
Apres beaucoup d'essais, je ne m'en sors pas...
Merci beaucoup pour vos retours!
Cordialement.
Frédéric
