[OL-2007] Renommer une PJ en utilisant l'objet du message [Résolu]

[didie78]

Bonjour,

J'ai un code VBA sur Outlook 2007 qui me permet d'enregistrer automatiquement lors de l'arrivé d'un nouveau message les pièces jointes vers le disque dur.

J'aimerai ajouter à ce code deux éléments mais ne connaissant pas trop le vba j'ai vraiment besoin d'aide.

J'ai besoin de renommer les pièces jointes : pour celà il faudrait qu'elle porte le nom de l'objet.
Ensuite j'aimerai que les messages soit déplacer dans un sous dossier outlook : ex : Archive

Voici mon script :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Sub script(Mail As mailitem)
    Dim myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myInbox As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
    Dim strName As String
    Dim i As Integer
 
    myOrt = "C:\Documents and Settings\Bureau\macro rename\titi\"
 
 
    For Each myItem In myInbox.Items
 
        strName = myItem.EntryID
 
        Set myAttachments = myItem.Attachments
        If myAttachments.Count > 0 Then
            'Ajoute une remarque dans le corps du message
            myItem.Body = myItem.Body & vbCrLf & _
                "pièce jointe enlevée:" & 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
    End If
 
    Next myItem
 
 
End Sub

Merci d'avance pour votre aide

Sandie

[didie78]

Bonjour,

Après une multitude de recherche j'ai enfin trouvé le code qui correspond à mon attente :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
  Sub save_pj(Mail As mailitem)
    Dim myAttachments, myAttachment As Object
    Dim myOrt As String
    Dim myOlApp As New Outlook.Application
    Dim myNamespace As Outlook.NameSpace
    Dim myInbox As Outlook.Folder
    Dim myItems As Outlook.Items
    Dim myItem As Object
    Set myNamespace = myOlApp.GetNamespace("MAPI")
    Set myInbox = myNamespace.GetDefaultFolder(olFolderInbox)
    Set myItems = myInbox.Items
    Set myAttachments = Mail.Attachments
    Dim strName As String
    Dim i As Integer
    Dim Ext
    Dim Nom As String  
 
    Nom = myAttachments.Item(1).DisplayName    
    Ext = Right(Nom, Len(Nom) - InStrRev(Nom, "."))   
 
    myOrt = "C:\Documents and Settings\MAIGNAN-SE\Bureau\macro rename\titi\" & Mail.Subject & "." & Ext
 
    For Each myItem In myInbox.Items
 
        strName = myItem.EntryID
 
        Set myAttachments = Mail.Attachments
        If myAttachments.Count > 0 Then
            'Ajoute une remarque dans le corps du message
            myItem.Body = myItem.Body & vbCrLf & _
                "pièce jointe enlevée:" & vbCrLf
 
            'for all attachments do...
            For i = 1 To myAttachments.Count
 
                'save them to destination
                myAttachments(i).SaveAsFile myOrt
                myItem.Body = myItem.Body & _
                    "File: " & myOrt & _
                     vbCrLf               
    Next i
    End If
    Next myItem
End Sub

Ce script lié à une règle permet d'enregistrer automatiquement la pièce jointe du message sur le disque dur en prenant comme nom l'objet du message et l'extension de la pièce jointe.

A bientôt

Sandie