Discussion :

[ArbreQuiPense]

Bonjour,

alléché par l'espoir d'améliorer ma macro de suppression des PJs, j'ai testé le code suivant:

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
105
106
107
108
109
110
111
112
113
114
115
116
117
'*************** Et la procédure à lancer depuis le mail ouvert
Public Sub Supprime_PJ()
' Ecrit par Fabrice NEBBIA
' Grace au travail de Géo, Anacoluthe, Isabelle Prawitz et Olivier CATTEAU
 
' Supprime les PJ du mail actif et insère le nom des PJ dans le corps du message
 
    Dim Courrier As MailItem
    Dim NomsPJ As String
 
    Dim NbPJ As Integer
    Dim i As Integer
    Dim pj As Attachment
    Dim Separateur As Variant
    Dim NbTiret As Integer
 
If Application.ActiveInspector Is Nothing Then Exit Sub
 
If MsgBox("Cette macro va supprimer les pièces jointes du mail et les remplacer par leur nom", _
vbYesNo + vbQuestion, "Etes vous sûr de vouloir exécuter cette macro ?") = vbNo Then Exit Sub
 
    Set Courrier = ActiveInspector.CurrentItem
    If Courrier Is Nothing Then Exit Sub
 
    Select Case Courrier.BodyFormat
        Case olFormatHTML:
            Separateur = "<BR>"
            NbTiret = 45
        Case olFormatPlain:
            Separateur = Chr(10)
            NbTiret = 35
        Case Else
            Separateur = " - "
            NbTiret = 50
    End Select
 
    NbPJ = Courrier.Attachments.Count
    If NbPJ = 0 Then
        MsgBox "Le messages en cours ne contient pas de pièce jointe"
        Exit Sub
    End If
 
    NomsPJ = IIf(NbPJ = 1, "Pièce jointe supprimée", "Pièces jointes supprimées") & " du message initial après lecture: " & Separateur & String(NbTiret, "-")
 
    For i = NbPJ To 1 Step -1
        Set pj = Courrier.Attachments(i)
        PJType = TypePJ(Courrier.EntryID, pj.Index)
        If PJType = "" Then
            NomsPJ = NomsPJ & Separateur & "- " & pj.FileName
            pj.Delete
        Else
            If MsgBox(pj.FileName & ": est une image ou un élément incorporé dans le corps du mail", vbYesNo, "Supprimer cette élément ?") = vbYes Then
            NomsPJ = NomsPJ & Separateur & "- " & pj.FileName & "(incorporé)"
            pj.Delete
            End If
        End If
 
    Next
 
    Select Case Courrier.BodyFormat
        Case olFormatHTML:
 
        OuCommenceAdresse = InStr(1, Courrier.HTMLBody, "<BODY", vbTextCompare)
        If OuCommenceAdresse > 0 Then
            fin = InStr(OuCommenceAdresse + 5, Courrier.HTMLBody, ">") + 1
            BaliseBody = Mid(Courrier.HTMLBody, OuCommenceAdresse, fin - OuCommenceAdresse)
 
            Courrier.HTMLBody = Replace(Courrier.HTMLBody, BaliseBody, BaliseBody & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & NomsPJ & "</font><BR>" _
                & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>", 1, 1, vbTextCompare)
        Else: Courrier.HTMLBody = "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & NomsPJ & _
                "</font><BR>" & "<font style='font-family: Tahoma ;font-size: 8pt ;color:#808080;font-style: italic;'>" & String(NbTiret, "-") & "</font><BR><BR>" & Courrier.HTMLBody
 
        End If
        Case Else
            Courrier.Body = NomsPJ & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & Courrier.Body
 
    End Select
 
 
    ' A activer pour enregistrer automatiquement les modifs
    'Courrier.Save
 
 
End Sub
 
 Function TypePJ(ByVal StrEntryID As String, attindex As Integer) As Variant
' Ecrit par Olivier CATTEAU
' Nécessite la référence à la librairie Microsoft CDO 1.21
 
' Le retour est <>"" si la PJ est la PJ zest un objet inséré dans le mail HTML
 
Dim oSession As Object 'MAPI.Session
  ' CDO objects
  Dim oMsg As Object 'MAPI.Message
  Dim oAttachs As Object 'MAPI.Attachments
  Dim oAttach As Object '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)
 
  TypePJ = strCID
  Set oMsg = Nothing
  oSession.Logoff
  Set oSession = Nothing
 
End Function

Malheureusement, ce code ne fonctionne pas chez moi (Windows 7 Entreprise SP1 / Outlook MS Office 2010) et supprime toutes les PJs sans distinction de type.

Par ailleurs, dans le code suivant:

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
Public Const BackupFileName As String = "AttachmentsList.txt"
 
Private Sub Build_AttachmentList(MonMail As MailItem)
' ***************************************************************************************
' Elaboration de la liste des 'vraies' PJ
' ---------------------------------------
' Une vrai pièce jointe est identifiée par un type vierge ("").
' La liste renseignée est celle de la boite de dialogue.
'
' ***************************************************************************************
 
  Dim Compteur As Integer
  Dim NbPJ As Integer
  Dim pj As Attachment
  Dim NomFichier As String
 
' ------------------
  Compteur = MonMail.Attachments.Count
 
  ' Chargement de la boite de dialogue pour MAJ de la liste.
  Load UF_Dev
  UF_Dev.LB_AttachmentsSelectionBox.Clear
 
  ' On ne traite un mail que s'il contient des PJ et qu'il n'a pas encore été traité.
  If (Compteur > 0) And _
     (MonMail.Attachments.Item(1).FileName <> BackupFileName) Then
     ' Initialisation
     NbPJ = 0
 
     ' parcours de toutes les PJ.
     For IPJ = 1 To Compteur
       Set pj = MonMail.Attachments(IPJ)
 
       NomFichier = pj.FileName
       PJType = pj.Type
 
       Debug.Print "[" & IPJ&; "]" & NomFichier & ": (" & PJType & ")"
 
         'UserFormListerAttachements.LB_PiècesJointes.AddItem NomFichier
     Next IPJ
  End If
End Sub
 
 
 
Sub CB_AttchmentsMngt()
  Dim UnMail As MailItem
' ------------------
  Set OlApp = New Outlook.Application
  On Error Resume Next
 
  For Each UnMail In Application.ActiveExplorer.Selection
     Build_AttachmentList (UnMail)
 
'    UF_Dev.Show
  Next
End Sub

L'appel à la fonction "Build_AttachmentList ne fonctionne pas ...
Greeee .... Ca ménerve !

Si quelqu'un peut m'aider ?...

Merci d'avance.

[Oliv-]

Bonjour,
Tu aurais eu plus de réponse en postant dans le sous forum VBA

Ily a effectivement une évolution a faire sur TypePJ , je recherche la solution que j'avais appliquée...

[Oliv-]

En fait la fonction PJType est ok si ton compte exchange est configuré avec l'option "Utiliser le mode Exchange mis en cache"

Est-ce un hébergement dans le cloud ?


Pour ta seconde macro le test du type n'est pas valable.

[ArbreQuiPense]

Configuration Outlook sur un poste d'entreprise ...
Secteur de la défense ...

On oublie tout ce qui est cloud et autre "clowneries" dans le genre ... pas assez secured !

Mode "exchange mis en cache".
Je ne sais pas ...
Je ne sais même pas comment savoir ...

[Oliv-]

Salut le mode exchange mis en cache tu le vois dans les paramètres du compte.

et dans la barre d'état c'est noté "Connecté à Microsoft Exchange" sinon si c'est pas activé c'est noté "En ligne avec exchange"

Pour obtenir l'état Embedded d'une image tu peux utiliser REDEMPTION

et ce code qui renvoi vrai ou faux

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Function Isembedded_RDO(ByVal StrEntryID As String, attindex As Integer) As Boolean
    Set RDOSession = CreateObject("Redemption.RDOSession")
    RDOSession.MAPIOBJECT = Application.Session.MAPIOBJECT
    Set mail = RDOSession.GetMessageFromID(StrEntryID)
    If mail.Attachments(attindex).contentID <> "" Then
        Isembedded_RDO = True
    Else
        Isembedded_RDO = False
    End If
 
End Function

[batseb]

Bonjour,

N'y a t il pas une autre solution pour Outlook 2010 sans voir besoin d'ajouter un composant externe? (Politique de ma boite : se limiter à Office 2010)

@+
Batseb

[ArbreQuiPense]

Bonjour,

Oliv, je suis en mode "Exchange mis en cache".

Batseb,

où veux-tu en venir ??

Merci.

[Oliv-]

Bonsoir,
J'ai trouvé une autre solution
je la met en forme et vous l'enverrai

[Oliv-]

voici la nouvelle fonction, utilisable à partir de OL2007 et sans autre bibliothèque

il faut lui transmettre un attachment

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
Function PJ_Isembedded(ByVal PJ As Attachment) As Boolean
'---------------------------------------------------------------------------------------
' Procedure : PJ_Isembedded pour OL2010
' Author    : OLIV-
' Date      : 27/11/2014
' Purpose   : Indique si une PIECE JOINTE est INCORPOREE dans le Corps du Mail
'---------------------------------------------------------------------------------------
'
    Dim oPA As Outlook.PropertyAccessor
 
    Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Const PR_ATTACHMENT_HIDDEN = "http://schemas.microsoft.com/mapi/proptag/0x7FFE000B"
 
    Set oPA = PJ.PropertyAccessor
'    MsgBox PJ & vbCr & "PR_ATTACHMENT_HIDDEN=" & oPA.GetProperty(PR_ATTACHMENT_HIDDEN) _
'         & vbCr & "PR_ATTACH_MIME_TAG=" & oPA.GetProperty(PR_ATTACH_MIME_TAG)
 
    If oPA.GetProperty(PR_ATTACH_CONTENT_ID) <> "" Then
        PJ_Isembedded = True
    Else
        PJ_Isembedded = False
    End If
 
End Function

voici un exemple

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
Sub Test_PJ_Isembedded()
 
    Dim l_Msg As MailItem
    Dim PJs As Outlook.Attachments
    Dim PJ As Outlook.Attachment
    Dim oPA As Outlook.PropertyAccessor
 
    'il faut un Email ouvert
    Set l_Msg = Application.ActiveInspector.CurrentItem
 
    'pour une création d'Email il faut l'enregistrer
    'l_Msg.Save
 
    ''check items for mime encoding
    If l_Msg.Attachments.Count > 0 Then
        ' attach items
        Set PJs = l_Msg.Attachments
        For x = 1 To PJs.Count
            Set PJ = PJs.Item(x)
 MsgBox PJ & vbCr & PJ_Isembedded(PJ), vbOKOnly, "Est-ce une PJ INCORPOREE ?"
        Next
    End If
 
    ' clean up email object
    Set l_Msg = Nothing
    Set PJ = Nothing
    Set PJs = Nothing
    Set oPA = Nothing
 
End Sub

[batseb]

Merci Oliv-

Ta solution fonctionne parfaitement avec Outlook 2010.

Bonne journée,

[ArbreQuiPense]

Merci Oliv-

2 questions ...

1. On la trouve où la documentation qui permet de trouver cela ?...
Respect !!

2. (Je sais ... Je suis XXXX, mais) ma macro traite une liste de mails sélectionnés dans un dossier, donc pas ouverts ...
Cela marchera-t-il encore ?...

J'essaie bientôt!

[Oliv-]

Salut,
Eh bien par hasard !
Mais en fait quand on est dans Oultook dans VBE et que l'on clique sur F1 il y a une rubrique NOUVEAUTES

On peut aussi la voir ici :http://msdn.microsoft.com/fr-fr/libr...ffice.14).aspx
ca a l'air plus complet.

et du coup on apprend plein de truc (je viens de le lire )

[ArbreQuiPense]

Merci.

J'utiliserai une partie de mes vacances pour remettre tout ça dans un packaging clean.
Je le posterai sur le site pour dispo à tous dans la foulée.