[Outlook 2007] - Copier une PJ sur le disque dur

[adv0541]

Bonjour à tous et enchanté car c'est mon premier post (même si je viens très régulièrement consulter le forum),

Je sais que des dizaines et des dizaines de sujets correspondent à mon problème. Toutefois, je viens vers vous car je n'ai pas réellement trouvé de solution.

Dans le cadre de mon travail, j'ai adapté une macro d'olivier Catteau http://outlook.developpez.com/faq/?page=VBA#Receive_Save_PJ permettant d'enregistrer sur le DD, les pièce jointe d'un mail. J'utilise cette macro en complément de certaines règles Outlook.

Jusqu'à aujourd'hui, j'utilisais Office 2002 et tout fonctionnait très bien...

Mon code adapté :

Sub extrait_PJ_vers_rep(strID As Outlook.MailItem)
MsgBox "ok"
' ***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 ##########################################################

        'J:\Téléphonie\mon répertoire\ doit déjà exister !!!

        Repertoire = "J:\mon répertoire\"
                
        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

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

En passant sous 2007, le script ne se lance plus.

J'ai plusieurs hypothèses :

1. C'est la règle qui ne marche pas car le msgbox en début de procédure n'apparait pas.
   Concernant la règle c'est une règle simple avec l'adresse du destinateur, un mot clef du corps de message, et le script. Jusqu'ici je n'avais pas eu de problème.
   
   
2. Une nouvelle référence est à activer sous 2007. Pour info, sont activés :
   • Visual Basic for Applications
   • MS Outlook 12.0 Object Library
   • OLE Automation
   • MS Office 12.0 Object Library
   • MS CDO for Windows 2000 Library
   • Microsoft Scripting Runtime
   • Microsoft CDO 1.21 Library
   
   
3. Dans ses instructions, Olivier Catteau incite à utiliser NewMailEx à partir de 2003. J'ai essayé de regarder sur quelques forums, mais j'avoue être un peu perdu avec celle-ci.

Merci d'avance pour votre aide.

Cordialement,
adv0541

 

[adv0541]

Re : [Outlook 2007] - Copier une PJ sur le disque dur

Cela marche désormais, je n'ai pas de réelle explication :S.
Le code pourra toutefois servir à ceux qui font face à la même problématique.

Merci quand même et bonne journée.

Cordialement,
adv0541

Edit : J'ai beau chercher, je ne trouve pas la fonction "résolu".