Discussion :

[CAPRI_456]

Bonsoir le Forum,

J'ai consulté de nombreuses FAQ et procédures de "forumistes" et notamment celles nombreuses d'OLIV sur le sujet :
"sauvegarder" des mails sur mon disque dur...."

j'ai cependant un ou l'autre soucis dans le code

1- les pièces jointes transférées dans mes répertoires n'y arrivent pas vraiment:
-- je pense qu'il s'agit d'une erreur au niveau de mon code (voir rouge) ou j'utilise "objMessage "

2- le deuxième soucis est que je dois absolument sélectionner un ou + mails dans mon inbox pour pouvoir faire le transfert,
or , je souhaiterai que outlook le réalise automatiquement , dès que le mail arrive et correspond à une règle de message basée sur la reconnaissance de l'expéditeur
__Dois-je éliminer le code suivant
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection

et le remplacer par quoi ?


merci pour votre aide...

CAPRI_456

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ PROCEDURE POUR EXPORTER LES PIECES JOINTES VERS DIFFERENTS REPERTOIRES
'++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'---------------------------------------------------------------------------------------------------
Private Sub Application_NewMail()

'Declaration
Dim myItems, myItem, myAttachments, myAttachment As Object
Dim myOrt As String
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim i As Integer

'Boîte de dialogue simple pour le chemin de sauvegarde
On Error Resume Next

'Actions sur les objets sélectionnés
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection

'boucle pour tous les mails

For Each myItem In myOlSel
Set myAttachments = myItem.Attachments
If myAttachments.Count > 0 Then


'for all attachments do... For i = 1 To myAttachments.Count

'========== ENREGISTREMENTS VERS DOSSIERS DE DESTINATION
'========== SPECIFIQUES SELON TYPE DE PIECES JOINTES
If UCase(Right(objMessage.Attachments.Item(i).FileName, 3)) = "csv" Then
objMessage.Attachments.Item(i).SaveAsFile "D:\csv\ & _"
objMessage.Attachments.Item(i).FileName
If "" = Dir("D:\csv\") Then MkDir ("D:\csv\")

If UCase(Right(objMessage.Attachments.Item(i).FileName, 3)) = "pdf" Then
objMessage.Attachments.Item(i).SaveAsFile "D:\pdf\ & _"
objMessage.Attachments.Item(i).FileName
If "" = Dir("D:\pdf\") Then MkDir ("D:\pdf\")

If UCase(Right(objMessage.Attachments.Item(i).FileName, 3)) = "doc" Then
objMessage.Attachments.Item(i).SaveAsFile "D:\doc\ & _"
objMessage.Attachments.Item(i).FileName
If "" = Dir("D:\doc\") Then MkDir ("D:\doc\")

If UCase(Right(objMessage.Attachments.Item(i).FileName, 3)) = "xls" Then
objMessage.Attachments.Item(i).SaveAsFile "D:\xls\ & _"
objMessage.Attachments.Item(i).FileName
If "" = Dir("D:\xls\") Then MkDir ("D:\xls\")


End If
End If
End If
End If

'===== Ajoute une remarque dans le corps du message qui signale suppresssion pièce jointe
myItem.Body = myItem.Body & vbCrLf & "pièce jointe enlevée et archivée sous:" _
& ("D:\csv\ou pdf ou doc ou xls") & "-nom fichier-" & myAttachments(i).DisplayName & vbCrLf

Next i

'=======Enlève les pièces jointes du message ' While myAttachments.Count > 0
' myAttachments(1).Delete
' Wend

'===='Sauvegarde le message sans ses pièces jointes
myItem.save
End If

Next

Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing

End Sub

[Tempusago]

je suis pas un super specialiste mais a mon avis tu as raison le probleme viens du faite que tu utilise objmessage.(ce qui doit correpsondre a l'objet du message).

a mon avis tu dois utiliser ca 'myAttachments'

un truc du genre myattachements(i).saveasfile

puisque tu definie myAttachments comme etant le mytiem.attachements(ce qui doit correspondre a la piece jointe.

mais a voir comme je dis je suis aussi novice que toi.

[CAPRI_456]

Bonsoir Tempusago, Le Forum,

Au fait, à force de visualiser les codes sur le Forum, j'ai réussi à construire :
-- deux procédures placées dans les modules
-- la première est appelée par une règle de message qui enclenche un script dans ThisoutlookSession.

Le 1er module : EXPORTER LES PIECES JOINTES VERS DIFFERENTS REPERTOIRES definis 'code commenté'

Le 2ème module :
'++++ A0 --- PARCOURIR INBOX à la recherche de MAILS
'++++ A1 --- TRANSFERT DES MAILS RECEPTIONNES (avec restrictions expéditeur et restrictions période )

les différents sujets m'ont été utiles
Si cela peut aider quelqu'un..... sait-on jamais....
CAPRI_456

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ PROCEDURE POUR EXPORTER LES PIECES JOINTES VERS DIFFERENTS REPERTOIRES definis
'++
'++ 'adapté par CAPRI_456 au départ du code d'olivier LEBEAU(développez.net)
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'---------------------------------------------------------------------------------------------------

'++++++ A0 ---- SCRIPT déclenché via règle des messages dans outlook 2003) dans ThisOutlookSession
Sub ManageAttachments()
'il est pratique d'ajouter une routine pour la gestion des erreurs dans votre macro
'afin d'identifier ou se situent les erreurs (une msg box apparaitra pour vous la signaler
'voir fin de la procédure

On Error GoTo GetAttachments_err

'Declare VARIABLES

Dim Ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item, Attachments As Object

Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer

' set values of variables = 'Actions sur les objets sélectionnés

Set Ns = GetNamespace("MAPI")
Set Inbox = Ns.GetDefaultFolder(olFolderInbox)
i = 0 'pour les annexes "Atmt"
'Declare VARIABLES pour " JOUR D'ANALYSE..."

Dim JourneeAnalyse As String
Dim today
Dim Jour As String, Mois As String, Annee As String
Annee = Year(Now)
Mois = Month(Now)
Jour = Day(Now)

today = Jour & "-" & Mois & "-" & Annee
JourneeAnalyse = Format(DateAdd("h", 6, today), "dd-mm-yy") 'renvoie today +6heures(du jour suivant)
'ceci permet d'incorporer les analyses lancées 6 heures après le jour début analyse

' cherche s'il existe des pièces jointes dans inbox (boite de réception )si pas , quitte procédureIf Inbox.Items.Count = 0 Then
'' MsgBox "AUCUN NOUVEL E-MAIL.", vbInformation, _
'' "Rien trouvé"
Exit Sub
End If
'--------------------------------------------------------------------------------------
' A0 ----RECHERCHE DE TOUS LES MAILS "CSV" dans INBOX (boucle)


For Each Item In Inbox.Items 'pour chaque mail dans l'Inbox


'--------------------------------------------------------------------------------------
' A1 ----ARCHIVAGE des fichiers CSV SUR LE "SERVEUR U "---- soit - (Chemin1)
' ----Avec numérotation incrémentée (format 000)
'--------------------------------------------------------------------------------------
For Each Atmt In Item.Attachments '''pour chaque pièce jointe aux mails

'If Right(Atmt.FileName, 3) = "csv" Then '''récupère uniquement les fichiers CSV
If Right(Atmt.FileName, 3) = "pdf" Then
Dim Chemin1 As String '''définit le répertoire de sauvegarde sur le serveur "U"
Chemin1 = "D:\\manifestes-csv-du-" & JourneeAnalyse If Dir(Chemin1, vbDirectory + vbHidden) = "" Then MkDir Chemin1 '...si le DOSSIER n'existe pas,le créer
ChDir Chemin1


FileName = Atmt.FileName 'sol1 :uniquement NOM FICHIER qui est le nom de l'annexe

' FileName = Format(Item.ReceivedTime, "dd-mm-yyyy--hh-mm_") & Atmt.FileName 'sol2 :date de réception du mail
'===== ici déclarer variables pour l'incrémentation....

'!!!!! ''nécessite d 'activer la reference Microsoft Scripting Runtime

Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder 'ou Scripting.FolderQQS
Dim nbFichiers As Integer
Dim SaveChanges

' ===== procède à l'incrémentation
'(calcule le nombre de fichiers déjà présent dans le répertoire scruté
'et donne le dernier numéro à l'incrémentation
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Chemin1)
nbFichiers = SourceFolder.Files.Count + 1
Atmt.SaveAsFile Chemin1 & "\" & Format(nbFichiers, "000") & "_" & Atmt

i = i + 1

End If

'--------------------------------------------------------------------------------------
' A2 ----SUPPRIME lES ANNEXES IDENTIFIEES & JOINTES A CHAQUE MAIL
'
'--------------------------------------------------------------------------------------

'===== AJOUTE REMARQUE dans le corps du mail qui signale suppresssion pièce jointe
'et lieu classement sur lE DISQUE dur Item.Body = Item.Body & vbCrLf & "pièces jointes archivées ::::" _
& Chemin1 & "::::" & Atmt.DisplayName & vbCrLf

'======= SUPPRIME les pièces jointes du message
Atmt.Delete COLOR="DarkGreen"]'attention désactivé pour ne pas supprimer lors d'essais[/COLOR]


Next Atmt 'traite la pièce jointe suivante

'--------------------------------------------------------------------------------------
' A3 1 ---- ENREGISTRE MAILS TRAITES SUR SERVEUR
' A3 2 ---- SUPPRIME MAILS DANS INBOX
'--------------------------------------------------------------------------------------

'====== 'ENREGISTRE MAILS SUR SERVEUR
Mod2_EnregMailsSurServeurOK.ParcourirInbox 'Appelle (Mod2_EnregMailsSurServeurOK)

'======= 'SUPPRIME les messages de l'INBOX
' Item.Delete 'attention désactivé pour ne pas supprimer lors d'essais



Next Item 'traite le mail suivant


'affiche un message quant au résultats de transfert des annexes

'' If i > 0 Then
'' MsgBox "Vous avez récupéré " & i & " fichiers CSV." _
'' & vbCrLf & "elles ont été enregistrées sur le serveur T:\" _
'' & vbCrLf & vbCrLf & "Bonne journée.", vbInformation, "TERMINE!"
'' Else
'' MsgBox "AUCUN fichier CSV n'est actuellement transmis -.", vbInformation, _
'' "Finished!"
'' End If
'-----------------------------------------------------------------------------------------
'======== clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set Ns = Nothing

Exit Sub
'-----------------------------------------------------------------------------------------

'======== handle errorsGetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit


End Sub

Le 2ème module :
'++++ A0 --- PARCOURIR INBOX à la recherche de MAILS
'++++ A1 --- TRANSFERT DES MAILS RECEPTIONNES (avec restrictions expéditeur et restrictions période )

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++ A0 --- PARCOURIR INBOX à la recherche de MAILS
'++++ A1 --- TRANSFERT DES MAILS RECEPTIONNES (avec restrictions expéditeur et restrictions période )
'++++
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'http://www.developpez.net/forums/d659803/logiciels/microsoft-office/outlook/
' vba-outlook/sauvegarder-selection-demail-specification-repertoire/


'++++++ A0 ---- PARCOURIR INBOX à la recherche de MAILS
'______________________________________________________________________________________________________
Sub ParcourirInbox()
'adapté au départ du code d'olivier LEBEAU(développez.net)

' ************************ Déclaration des Objets et variables
Dim MonApply As Outlook.Application
Dim MonMail As Outlook.MailItem
Dim MonNSpace As Outlook.NameSpace
Dim FldDossier As Outlook.MAPIFolder

' ************************* Instance des Objets
Set MonApply = Outlook.Application 'Application Outlook
Set MonNSpace = MonApply.GetNamespace("MAPI") 'Banque MAPI
Set FldDossier = MonNSpace.GetDefaultFolder(olFolderInbox) 'boîte de réception


' ************************* Declare VARIABLES pour " JOUR D'ANALYSE..."
Dim JourneeAnalyse As String
Dim today
Dim Jour As String, Mois As String, Annee As String
Annee = Year(Now)
Mois = Month(Now)
Jour = Day(Now)

today = Jour & "-" & Mois & "-" & Annee

' =========== Introduit une restriction horaire (période de réception)
JourneeAnalyse = Format(DateAdd("h", 6, today), "dd-mm-yy") 'renvoie today +6heures(du jour suivant)

'Boucle afin de parcourir l'ensemble des E-mails présents dans le dossier Boîte de réception
For Each MonMail In FldDossier.Items

'========= Introduit une restriction sur l'expéditeur du MAIL

If MonMail.SenderEmailAddress = "SystemFileWatcher@xxx.com" Then 'à adapter
sav_mail_as_msg MonMail 'applique la procédure en A1 ci-dessous
End If

Next MonMail

'Vide des instances
Set MonApply = Nothing
Set MonNSpace = Nothing
Set FldDossier = Nothing
Set MonMail = Nothing

End Sub

'A1 --- TRANSFERT DES MAILS

Sub sav_mail_as_msg(Optional objCurrentMessage As Object)


'==== scrute si message existent dans inbox

If objCurrentMessage Is Nothing Then Set objCurrentMessage = ActiveInspector.CurrentItem
'===== Ici on construit le nom du fichier qui sera créé en vue d'être stocké disque dur
'===== DATE RECEPTION du MAIL(="ReceivedTime")+ Nom(=Objet du msg)

NomExport = Format(objCurrentMessage.ReceivedTime, "dd-mm-yyyy hh-mm") & "_" & objCurrentMessage.Subject


'====== Declare VARIABLES pour " JOUR D'ANALYSE..."

Dim JourneeAnalyse As String
Dim today
Dim Jour As String, Mois As String, Annee As String
Annee = Year(Now)
Mois = Month(Now)
Jour = Day(Now)

today = Jour & "-" & Mois & "-" & Annee
JourneeAnalyse = Format(DateAdd("h", 6, today), "dd-mm-yy") 'renvoie today +6heures(du jour suivant)
'ceci permet d'incorporer les analyses lancées 6 heures après le jour début analyse

'====== Definition répertoire de destination sur le serveur "U"

Dim Chemin2 As String '''définit le répertoire de sauvegarde sur le serveur "U"
Chemin2 = ("D:\Mails-reçus-TNT-") & JourneeAnalyse
If Dir(Chemin2) <> "" Then MkDir Chemin2 '...si le DOSSIER n'existe pas,le créer
'ChDir Chemin2


'======'Ici on supprime les caractères non autorisé dans les noms de fichiers
PathNomExport = Chemin2 & "\" & "reçu_" & Left _
(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
NomExport, "\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "<", ""), ">", ""), "|", ""), ".", ""), """", ""), _
vbTab, ""), Chr(7), ""), 160) & ".msg"

'===== Ici évite d'écraser les messages identiques , donc ajouté une incrémentation automatique
'===== PAS UTILE pour nos besoins
''' 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
'===== pour terminer, on enregistre dans le répertoire prédéfini sur le disque dur
objCurrentMessage.SaveAs PathNomExport, OlSaveAsType.olMsg
End Sub