récupération de Pièce jointe outlook

[laurent999]

Bonjour à tous,

J'ai récupéré cette macro réalisé par Olivier Catteau, elle fonctionne très bien mais n'est pas adaptée à mon problème.

Comme je ne suis pas un expert, je n'arrive pas à m'en sortir.
Ici la macro regarde dans le fichier temp\pj si la pièce jointe existe, dans le cas ou elle existe, l'ancienne pj est enregistrée dans un fichier old.
Or, dans mon cas le nom de la pj est toujours identique, alors je voudrais qu'au lieu que le fichier old soit créé pour enregistrer ma pièce jointe,la macro compte le nombre de pj ayant le nom "ordre" et ajoute 1.

en enregistrement, nous aurions donc ordre1.xml puis ordre2.xml etc...

Merci d'avance,

Laurent



Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)

' ***olivier CATTEAU***

' 23 avril 2007

Dim olNS As Outlook.NameSpace
Dim MyMail As Outlook.MailItem

Dim expediteur
Set olNS = Application.GetNamespace("MAPI")
Set MyMail = olNS.GetItemFromID(strID.EntryID)

'MsgBox "nouveau message"

If MyMail.Attachments.Count > 0 Then

expediteur = MyMail.SenderEmailAddress

'on crée le répertoire où mettre les fichiers joints ##########################################################

'c:\temp\pj\ doit déjà exister !!!

Repertoire = "c:\temp\pj\"

If Repertoire <> "" Then

If "" = Dir(Repertoire, vbDirectory) Then

MkDir Repertoire

End If

End If

'on traite les pj

Dim PJ, typeatt

For Each PJ In MyMail.Attachments
'vérification si c'est une PJ Embedded

typeatt = Isembedded(strID, PJ.Index)

If typeatt = "" Then

If "" <> Dir(Repertoire & PJ.FileName, vbNormal) Then

MsgBox Repertoire & PJ.FileName & " existe !!"

'si existe copie vers le répertoire old

If "" = Dir(Repertoire & "old", vbDirectory) Then

MkDir Repertoire & "old"

End If

FileCopy Repertoire & PJ.FileName, Repertoire & "old\" & PJ.FileName

End If

PJ.SaveAsFile Repertoire & PJ.FileName

End If

Next PJ

'drapeau vert

MyMail.FlagIcon = olGreenFlagIcon

'Marque lu

MyMail.UnRead = False

MyMail.Save



End If

Set MyMail = Nothing
Set olNS = Nothing

Fin:

End Sub



' Function: Fields_Selector

' Purpose: View type of attachment

' olivier catteau fevrier 2006

Function Isembedded(ByVal strEntryID As String, attindex As Integer) As Variant

Dim oSession As MAPI.Session
' CDO objects

Dim oMsg As MAPI.Message
Dim oAttachs As MAPI.Attachments

Dim oAttach As MAPI.Attachment

' initialize CDO session

On Error Resume Next

Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False

' get the message created earlier

Set oMsg = oSession.GetMessage(strEntryID)
' set properties of the attached graphic that make

' it embedded and give it an ID for use in an image tag

Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String

strCID = oAttach.Fields(&H3712001E)

Isembedded = strCID

Set oMsg = Nothing

oSession.Logoff

Set oSession = Nothing

End Function

 

[laurent999]

Re : récupération de Pièce jointe outlook

Bonjour a tous,

Voilà cela fonctionne,

Ci-joint la sub modifiée:

Ouvrir outlook Alt+F11 insertion module
coller la Sub

Puis affecter une règle à vos messages.
par ex: pour message entrant ayant pour objet "commande"
puis cocher utiliser un script cliquez sur script le choix apparait.
puis cocher arrêter de traiter plus de règles .

Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)


Dim olNS As Outlook.NameSpace
Dim MyMail As Outlook.MailItem
Dim olInbox As Outlook.MAPIFolder

Dim expediteur
Set olNS = Application.GetNamespace("MAPI")
Set MyMail = olNS.GetItemFromID(strID.EntryID)

If MyMail.Attachments.Count > 0 Then
Repertoire = "c:\temp\pj\"
Dim PJ, typeatt
Dim x As Integer
Dim q As String
q = Dir(Repertoire & "*.xml")

For Each PJ In MyMail.Attachments
If PJ.FileName = "order.xml" Then
Do While q <> ""
x = x + 1
q = Dir()
Loop

PJ.SaveAsFile Repertoire & "Order" & x & ".xml"
End If


Next PJ

MyMail.FlagIcon = olGreenFlagIcon

MyMail.UnRead = False

MyMail.Save

End If


Set MyMail = Nothing
Set olNS = Nothing

Fin:

End Sub