Discussion :

[michdvp]

Bonjour,
Mon but est d'extraire les pièces jointes de mes courriers Emails et de les mettre dans un dossier spécifique sur mon DDur.
Ce sujet ayant déjà été traité, j'ai pu récupérer le code ci-dessous et cela fonctionne très bien quand les pièces jointes portent des noms différents.
Le problème est que lorsque les pièces jointes (xxx.jpg par exemple) portent toutes le même nom, je ne récupère que la dernière, les autres se trouvant écrasées par celle-ci.
Ayant très peu de connaissances en VBA, je ne parviens pas à modifier le code pour que mes pièces jointes soient renommées, par exemple grâce à la date et l'heure du document qui la contient, ou autre système.
Je précise que l'expéditeur est aussi toujours le même (Logiciel de sécurité).
Si vous pouvez m'aider, je vous en remercie à l'avance.
Michel
_______________________________________________

Sub SavePhotosPJ()

'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
myOrt = InputBox("Destination", "Save Attachments", "E:\_-Photos\_Camerassecurite\")

On Error Resume Next

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

'boucle
For Each myItem In myOlSel
Set myAttachments = myItem.Attachments
If myAttachments.Count > 0 Then
'Ajoute une remarque dans le corps du message
myItem.Body = myItem.Body & vbCrLf & _
"Pièces jointes copiées:" & vbCrLf

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

'save them to destination
myAttachments(i).SaveAsFile myOrt & _
myAttachments(i).DisplayName
myItem.Body = myItem.Body & _
"File: " & myOrt & _
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

[Oliv-]

Bonjour,
regarde cet exemple au niveau de PathNomExport ...

http://www.developpez.net/forums/blo...yperlien-mail/

[michdvp]

Bonjour,
regarde cet exemple au niveau de PathNomExport ...

http://www.developpez.net/forums/blo...yperlien-mail/

Merci, c'est sympa.
J'ai beau relire le code dans tous les sens, je ne parviens pas à utiliser ce qui concerne PathNomExport et à l'adapter dans mon code existant.
Je suis loin d'avoir le niveau nécessaire.
Merci en tout cas de ton aide.
Je vais continuer à fouiller, c'est un peu comme ça qu'on apprends.
Merci encore.

[Oliv-]

Bonjour,

En utilisant mon programme (lien précédent)

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
Sub Lance_Export_PJ_sur_selection()
    Dim MonOutlook As Outlook.Application
    Dim mail As Object
    Dim LeMail As Outlook.MailItem
    Dim LesMails As Object
    Set MonOutlook = Outlook.Application
    Set LesMails = MonOutlook.ActiveExplorer.Selection
 
    Dim DossierExport
    DossierExport = InputBox("Destination", "Save Attachments", "E:\_-Photos\_Camerassecurite\")
    For Each LeMail In LesMails
        If LeMail.Class = olMail Then
            Call ExportSuppression_PJ_v2(myMail:=LeMail, Export:=True, Supp:=False, SuppEmbedded:=False, DirExport:=DossierExport & "\", Deplace:=False, DossierMove:="", BodyWrite:=True)
 
        End If
 
    Next LeMail
 
    Set LesMails = Nothing
 
End Sub