Discussion :

[flacdomatmut]

Bonjour, j'ai un soucis sur une règle de macro e sauvegarde des pièces jointes, je souhaite interdire la sauvegarde des png jpg et gif du coup j'ai fais ca et ca marche pas :

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
Sub SauvegarderPiecesattacheesnonarchive()
 
    Dim olApp As Outlook.Application
    Dim objItem As Outlook.MailItem
    Dim NbrPiecesAttachees As Integer
    Dim nomFichier As String
    Dim NumeroFichierAttache
    Dim Compteur
 
    Set olApp = New Outlook.Application
 
    On Error Resume Next
 
    Compteur = 1
    For Each objItem In Application.ActiveExplorer.Selection
 
        NbrPiecesAttachees = objItem.Attachments.Count
 
        For NumeroFichierAttache = 1 To NbrPiecesAttachees Step 1
            'place le nom du fichier qui va être supprimé dans le corps du mail
            nomFichier = objItem.Attachments.Item(NumeroFichierAttache).FileName
                   If nomFichier = ".jpg" Then
     objItem.Delete
            End If
            If nomFichier = ".png" Then
         objItem.Delete
            End If
            If nomFichier = ".gif" Then
           objItem.Delete
            End If
 
            objItem.Attachments.Item(NumeroFichierAttache).SaveAsFile ("C:\Users\pavot.cyprien1e\Music\" & Compteur & nomFichier)
            Compteur = Compteur + 1
             If nomFichier = ".jpg" Then
     objItem.Delete
            End If
            If nomFichier = ".png" Then
         objItem.Delete
            End If
            If nomFichier = ".gif" Then
           objItem.Delete
            End If
 
        Next
Set objItem = Nothing
    Next
 
 
MsgBox "C'est bon les pièces jointes ont été copiés avec succés dans C:\Users\pavot.cyprien1e\Documents\musique\"
End Sub

[pc75]

Bonjour,

A la place de ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
If nomFichier = ".jpg" Then
objItem.Delete
End If

Tu as essayé ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
If Right(nomFichier, 4) = ".jpg" Then
objItem.Delete
End If

[Oliv-]

Bonjour,
Effectivement, c'est pas bon.
regarde là
en dessous de

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For Each PJ In MyMail.Attachments

tu peux faire ton test

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
if PJ.FileName like "*.jpg" or PJ.FileName like "*.png" then
next PJ
' rien
END IF

où là

[flacdomatmut]

Le soucis c'est qu'il me dit qu'il n'y a pas de for déclaré pour le next du coup je sais pas ou déclarer ce for

[flacdomatmut]

Finalement le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
If Right(nomFichier, 4) = ".jpg" Then
objItem.Delete
End If

fonctionne, mais que pour les jpg, quand je modifie en .png et .gif, cela n'est pas pris en compte pourquoi ? merci d'avance

[pc75]

Re,

Tu as peut-être des noms de fichier en majuscules ?

Si c'est le cas, mets ça :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
If uCase(Right(nomFichier, 4)) = ".JPG" Or uCase(Right(nomFichier, 4)) = ".PNG"  Or uCase(Right(nomFichier, 4)) = ".GIF" Then
objItem.Delete
End If

[Oliv-]

sauf erreur avec le code suivant tu supprimes le mail en entier, il pourrait contenir plusieurs PJ

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

objItem.Delete

et si tu supprimes des mail il faut commencer à l'envers ta boucle

[flacdomatmut]

Ta proposition de code fonctionne toujours mais que pour les jpg , les png et les gif ne sont pas supprimés curieux non ?

[pc75]

Re,

Tu peux nous montrer ton code modifié ?

[flacdomatmut]

Salut, j'ai finis par réussir à faire ce que je voulais fgràce à vous deux je vous en remercie et vous souhaite bonne continuation, à bientôt peut-être !!

Le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
If Right(nomFichier, 4) = ".png" Or Right(nomFichier, 4) = ".gif" Or Right(nomFichier, 4) = ".jpg" Or Right(nomFichier, 4) = ".GIF" Or Right(nomFichier, 4) = "PNG" Or Right(nomFichier, 4) = ".JPG" Then
objItem.Delete
End If

[flacdomatmut]

Finalement je fais appel à vous encore une fois car je ne veux pas que le mail soit supprimer je veux juste éviter de sauvegarder les pngs. Quel alternative j'ai pour cela ?

[Oliv-]

Bonjour,
Effectivement, c'est pas bon.
regarde là
en dessous de

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

For Each PJ In MyMail.Attachments

tu peux faire ton test

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
if PJ.FileName like "*.jpg" or PJ.FileName like "*.png" then
next PJ
' rien
END IF

où là

As tu consulté le lien de ma réponse ci-dessus ?

[flacdomatmut]

Oui je l'ai consulté, mais je n'ai rien trouvé sur les règles interdisant les pièces jointes de type images sans supprimer l'email, en outre j'ai essayer ton code, mais il ne fonctionne pas, ou alors je ne sais pas bien ou le mettre. Je sais que je ne suis pas bien doué en VBA c'est pourquoi je fais appel à vous et je vous remercie déjà de ce que vous avez pu faire pour moi

[Oliv-]

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
Sub ENREGISTRE_PJ_SELECTION()
Dim objItem as item
Dim StrID As Outlook.MailItem
 
For Each objItem In Application.ActiveExplorer.Selection
if    objItem.class=.Class = olMail then 
 
     Set StrID = objItem
     call extrait_PJ_vers_rep (StrID)
End if
Next 
End Sub
 
 
 
Sub extrait_PJ_vers_rep(StrID As Outlook.MailItem)
' ***olivier CATTEAU*** script
' 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
 
    'on crée le repertoire où mettre les fichiers joints ##########################################################
 
    Repertoire = "C:\Users\pavot.cyprien1e\Music\"
 
    'If Repertoire <> "" Then
    '    If "" = Dir("d:\temp\", vbDirectory) Then
    '        MkDir "d:\temp\"
    '    End If
    '    If "" = Dir(Repertoire, vbDirectory) Then
    '        MkDir Repertoire
    '    End If
    'End If
 
 
 
    'on traite les pj
    Dim pj, TypeAtt
    For Each pj In myMail.Attachments
 
         if UCASE(PJ.FileName) like "*.JPG" or PJ.FileName like "*.PNG"  or PJ.FileName like "*.GIF" then
GOTO              nextPJ
             ' rien
           END IF
 
            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
nextPJ:
    Next pj
 
 
 
''on déplace le mail vers un dossier outlook
'Dim myDestFolder As Outlook.MAPIFolder
 
'Set myDestFolder = myMail.Parent.folders("test")
'myMail.Move myDestFolder
 
End If
Set myMail = Nothing
Set olNS = Nothing
fin:
End Sub

[flacdomatmut]

J'ai tésté ton code et il n'a pas fonctionné, je me sens un peu nul

[Oliv-]

c'est à dire ? as tu esayé en pas à pas ?

[flacdomatmut]

J'ai finalement modifié par un autre code et dans ma tête quand on arrive à l'enregistrement des pièces jointes, je place mon if qui dit que pour une piecejointe.filename different de .jpg , then on execute le code. Est-ce que je me trompe ?

le code (pas fonctionnel pour une raison qui m'est inconnue (la requete fonctionne, mais j'ai toujours des jpg png ...)) :

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
Sub SaveAttachment()
 
'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", "C:\Users\pavot.cyprien1e\Documents\flac\")
 
On Error Resume Next
 
'Actions sur les objets sélectionnés
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
 
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èce jointe enlevée:" & vbCrLf
 
'for all attachments do...
For i = 1 To myAttachments.Count
If myAttachments.FileName <> "*.jpg" Or myAttachments.FileName Like "*.png" Then
'save them to destination
myAttachments(i).SaveAsFile myOrt & _
myAttachments(i).DisplayName
myItem.Body = myItem.Body & _
"File: " & myOrt & _
myAttachments(i).DisplayName & vbCrLf
End If
Next i
 
 
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,
ton test n'est pas bon

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If myAttachments.FileName <> "*.jpg" Or myAttachments.FileName Like "*.png" Then

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If NOT UCASE(myAttachments.FileName) like "*.JPG" AND NOT UCASE(myAttachments.FileName) Like "*.PNG" Then

il faut respecter les MAJUSCULES

[flacdomatmut]

Malgré ta modification, les jpg et les pngs sont encore présent, cela doit venir du "*.JPG" non ?

[Oliv-]

je n'avais pas vérifié tes déclarations de variable et l'usage de ON ERROR RESUME NEXT fait que tu n'as pas de remonté d'erreur.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If NOT UCASE(myAttachments(i).FileName) like "*.JPG" AND NOT UCASE(myAttachments(i).FileName) Like "*.PNG" Then

il faut respecter les MAJUSCULES[/QUOTE]