Discussion :

[LANGAZOU]

Bonjour,

J'ai un mail sous "OUTLOOK" que je reçois quotidiennement et qui contient une pièce jointe. je voudrais extraire automatiquement cette pièce jointe (avec un script) dès sa réception et l'enregistrer sous bureau avec écrasement de l'ancienne pièce jointe déjà enregistrée ( car elle porte le même nom de fichier).

Merci pour votre aide.

[Oliv-]

Bonjour,

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

[LANGAZOU]

Bonjour Oliv,

ce script incrémente le nom du fichier par 1. je voudrais que le fichier existant qui porte le même nom se remplace automatiquement, j'ai pas su comment le modifier malheureusement :/

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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
Sub REGLE_Financement_PJ_vers_rep(StrID As Outlook.MailItem)
' ***olivier CATTEAU*** script
' 23 avril 2007
'modif 02 06 2015
 
    Dim olNS As Outlook.NameSpace
    Dim MyMail As Outlook.MailItem
    Dim expediteur
    If Not StrID.Class = olMail Then Exit Sub
    Set MyMail = StrID
 
 
 
 
    'MsgBox "nouveau message"
 
    If MyMail.Attachments.Count > 0 Then
        expediteur = MyMail.SenderEmailAddress
 
        'on crée le repertoire où mettre les fichiers joints ##########################################################
        Repertoire = "C:\Users\SEB\Desktop\"
 
 
        'on traite les pj
        Dim pj, TypeAtt
        For Each pj In MyMail.Attachments
            'vérification si c'est une  PJ  Embedded
            'TypeAtt = PJ_Isembedded(pj)
TypeAtt = False
            If TypeAtt = False Then
                N = 1
                MemPath = pj.FileName
                PathNomExport = MemPath
                While Dir(Repertoire & PathNomExport) <> ""
                    'MsgBox "Le fichier " & vbCr & PathNomExport & vbCr & "existe déjà", vbInformation
                    PathNomExport = "(" & N & ")" & MemPath
                    N = N + 1
                Wend
                pj.SaveAsFile Repertoire & PathNomExport
            End If
        Next pj
 
 
        'drapeau vert
        MyMail.FlagIcon = olGreenFlagIcon
        'Marque lu
        MyMail.UnRead = False
        MyMail.Save
        'on déplace le mail vers le sous dossier outlook traité
        On Error Resume Next
        Dim myDestFolder As Outlook.MAPIFolder
        Set myDestFolder = MyMail.Parent.Folders("Traité")
        On Error GoTo 0
        If myDestFolder Is Nothing Then
        Set myDestFolder = MyMail.Parent.Folders.Add("Traité")
        End If
 
        MyMail.Move myDestFolder
 
    End If
    Set MyMail = Nothing
    Set olNS = Nothing
fin:
End Sub
 
Function waaps_creedir(lerep As String) As Boolean
'----------------------------------------------------------------------
' FUNCTION :    waaps_creedir
'               Création d'un répertoire (récursif)
'----------------------------------------------------------------------
' Paramètres :
'   rep :       répertoire à créer par son chemin relatif % au root
'----------------------------------------------------------------------
'   retour :    True si le répertoire est créé
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------
' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
'   Utilisation commerciale interdite
'   Utilisation personnelle / professionnelle autorisée
'   Le message courant doit être préservé
'----------------------------------------------------------------------
    Dim fso As FileSystemObject, i As Integer, retour As Boolean
    Dim rp As String, r
 
    Set fso = CreateObject("Scripting.filesystemobject")
 
    rp = Replace(lerep, "\", "/")
    rp = Replace(rp, "//", "/")
    rep = Split(rp, "/")
    r = REP_TOP
    retour = True
    For i = 0 To UBound(rep)
        If (rep(i) <> "") Then
            r = r & rep(i) & "\"
            If (Not fso.FolderExists(r)) Then
                fso.CreateFolder (CStr(r))
                If (Not fso.FolderExists(r)) Then retour = False
            End If
        End If
    Next
    Set fso = Nothing
    waaps_creedir = retour
End Function

[Oliv-]

SAlut,
comme cela

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
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
Sub REGLE_Financement_PJ_vers_rep(StrID As Outlook.MailItem)
' ***olivier CATTEAU*** script
' 23 avril 2007
'modif 02 06 2015
 
    Dim olNS As Outlook.NameSpace
    Dim MyMail As Outlook.MailItem
    Dim expediteur
    If Not StrID.Class = olMail Then Exit Sub
    Set MyMail = StrID
 
 
 
 
    'MsgBox "nouveau message"
 
    If MyMail.Attachments.Count > 0 Then
        expediteur = MyMail.SenderEmailAddress
 
        'on crée le repertoire où mettre les fichiers joints ##########################################################
        Repertoire = "C:\Users\SEB\Desktop\"
 
 
        'on traite les pj
        Dim pj, TypeAtt
        For Each pj In MyMail.Attachments
            'vérification si c'est une  PJ  Embedded
            'TypeAtt = PJ_Isembedded(pj)
TypeAtt = False
            If TypeAtt = False Then
                N = 1
                MemPath = pj.FileName
                PathNomExport = MemPath
 
 
 
 
                pj.SaveAsFile Repertoire & PathNomExport
            End If
        Next pj
 
 
        'drapeau vert
        MyMail.FlagIcon = olGreenFlagIcon
        'Marque lu
        MyMail.UnRead = False
        MyMail.Save
        'on déplace le mail vers le sous dossier outlook traité
        On Error Resume Next
        Dim myDestFolder As Outlook.MAPIFolder
        Set myDestFolder = MyMail.Parent.Folders("Traité")
        On Error GoTo 0
        If myDestFolder Is Nothing Then
        Set myDestFolder = MyMail.Parent.Folders.Add("Traité")
        End If
 
        MyMail.Move myDestFolder
 
    End If
    Set MyMail = Nothing
    Set olNS = Nothing
fin:
End Sub
 
Function waaps_creedir(lerep As String) As Boolean
'----------------------------------------------------------------------
' FUNCTION :    waaps_creedir
'               Création d'un répertoire (récursif)
'----------------------------------------------------------------------
' Paramètres :
'   rep :       répertoire à créer par son chemin relatif % au root
'----------------------------------------------------------------------
'   retour :    True si le répertoire est créé
'----------------------------------------------------------------------
' Global utilisé : REP_TOP
'----------------------------------------------------------------------
' COPYRIGHTS : 1994-2005 CAXTON / WAAPS / BRUNO VILLACAMPA
'   Utilisation commerciale interdite
'   Utilisation personnelle / professionnelle autorisée
'   Le message courant doit être préservé
'----------------------------------------------------------------------
    Dim fso As FileSystemObject, i As Integer, retour As Boolean
    Dim rp As String, r
 
    Set fso = CreateObject("Scripting.filesystemobject")
 
    rp = Replace(lerep, "\", "/")
    rp = Replace(rp, "//", "/")
    rep = Split(rp, "/")
    r = REP_TOP
    retour = True
    For i = 0 To UBound(rep)
        If (rep(i) <> "") Then
            r = r & rep(i) & "\"
            If (Not fso.FolderExists(r)) Then
                fso.CreateFolder (CStr(r))
                If (Not fso.FolderExists(r)) Then retour = False
            End If
        End If
    Next
    Set fso = Nothing
    waaps_creedir = retour
End Function

[LANGAZOU]

Merci beaucoup Olivier vous êtes le plus grand sauveur de ce forum