Dimanche 22 Octobre 2017  
Navigation
FAQ Outlook
» Foire Aux Questions «
Recherche
Téléchargements
Forums Outlook
Plan du site
Liens
Login

Les inscriptions sont fermées

Pseudo

Mot de passe

Se souvenir de moi



Mot de passe oublié ? Mot de passe oublié ?
Connexions
Bienvenue à [FAMACLUB]
le 1,414ème membre
Visiteurs en ligne : 3
Membres en ligne : 0

 EMERGENCY 12 semaines
 callaghi 14 semaines
 JièL 16 semaines
 zorro71 20 semaines
 Alphator 39 semaines
 ande 44 semaines
 Oliv 46 semaines
 cubitus 50 semaines
 angel 60 semaines
 Quartzkyte 69 semaines

Non activés :0

Nombre de visiteurs
depuis le : 12/11/2008

Aujourd'hui:1 032
En ligne :3
Max. en ligne:312
Max. / jour:66 529
Total hier:4 661
Total ce mois:111 087
Total visites:18 501 984
Moyenne/jour:5 667

Dernières 24h

























Publicité ; elle permet de financer le site
Navigation parmi les catégories/articles
« Catégorie     Q15000 Macros - VBA (41)  Catégorie »
[<<]  « Article  Article »  [>>]
R15220 [VBA] Supprimer les Pièces jointes.

Permet de supprimer les PJ du mail et ajoute dans le corps du mail le nom de cette PJ.
2 versions sont disponibles.


Sub Supprime_PJ()
' *** Supprime les pièces jointes des messages en HTML en insérant leur nom***
' *** Vous en avez rêvé, Anacoluthe l'a fait ;-) ***
' *** modifié le 31/11/2004 par Isabelle Prawitz et le 20/7/2005 par olivier CATTEAU***
Dim ListePJ As String

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 ?") = vbYes Then
If Application.ActiveInspector Is Nothing Then
GoTo Fin
End If
Set oMessage = ActiveInspector.CurrentItem
' en decommentant cette ligne vous pouvez boucler sur tous les mails selectionnés.
'For Each oMessage In ActiveExplorer.Selection
If oMessage.BodyFormat = olFormatHTML And _
oMessage.Attachments.Count > 0 Then
ListePJ = ""
For Each PJ In oMessage.Attachments
ListePJ = ListePJ & "<br>" & PJ.FileName
Next PJ

While oMessage.Attachments.Count > 0
oMessage.Attachments.Remove 1
Wend

ListePJ = "[Le Mail d'origine comportait les Pièces Jointes suivantes: " _
& ListePJ & "<br>" & "supprimées après lecture]"
oMessage.HTMLBody = ListePJ & "<br>" & oMessage.HTMLBody
oMessage.Save
End If
If oMessage.BodyFormat = olFormatPlain And _
oMessage.Attachments.Count > 0 Then
ListePJ = ""
For Each PJ In oMessage.Attachments
ListePJ = ListePJ & Chr(10) & PJ.FileName
Next PJ
While oMessage.Attachments.Count > 0
oMessage.Attachments.Remove 1
Wend

ListePJ = "[Le Mail d'origine comportait les Pièces jointes suivantes: " _
& ListePJ & Chr(10) & "supprimées après lecture]"
oMessage.Body = ListePJ & oMessage.Body
oMessage.Save
End If
'oMessage.PrintOut
'à décommenter pour la boucle for
'Next oMessage
End If
Fin:
End Sub

 



Voici une autre version avec un peu de mise en forme.

Mise à jour le 27/01/2011 :
Cette macro propose désormais le choix entre l'insertion d'une mention dans le corps du mail et/ou l'ajout d'un fichier texte en PJ pour lister les pièces jointes d'origines.

Les fonctions suivantes sont nécessaires :

Public 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

' Pour Outlook 2007 il faut le télécharger là :
' http://www.microsoft.com/downloads/details.aspx?familyid=2714320d-c997-4de1-986f-24f081725d36&displaylang=en

' Le retour est <>"" si la PJ est un objet inséré dans le mail HTML

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

 

Public Function MailActif() As MailItem
' Ecrit par Fabrice NEBBIA avec l'aide de Géo et Olivier CATTEAU
    
' Renvoie le mail ouvert
' Si aucun élément n'est ouvert ou s'il ne s'agit pas d'un mail
' Un message l'indique et la valeur renvoyée est Nothing

    Dim Inspecteur As Inspector
    
    Set MailActif = Nothing
    
    Set Inspecteur = ActiveInspector
    
    ' y a t-il un affichage d'item actif
    If Inspecteur Is Nothing Then
        MsgBox "Aucun élément n'est ouvert actuellement", vbCritical
        Exit Function
    End If
    
    'Cet affichage concerne-t-il un courrier ?
On Error Resume Next
    Set MailActif = Inspecteur.CurrentItem
    If Err <> 0 Then
    MsgBox "L'élément en cours n'est pas un e-mail", vbCritical
    Exit Function
    End If
On Error GoTo 0

End Function



'*************** Et la macro à lancer depuis le mail ouvert

 

Public Sub Suppression_PJ_originales()
' Ecrit par Fabrice NEBBIA
' Grace au travail de Géo, Anacoluthe, Isabelle Prawitz et Olivier CATTEAU

' Fonction à ajouter dans le projet :
'   Public Function MailActif() As MailItem
'   Public Function TypePJ(ByVal strEntryID As String, attindex As Integer) As Variant

' Supprime les PJ du mail actif avec une mention pour mémoire selon 2 formes
' Mention insérée dans le corps du message
' et/ou insertion d'un fichier texte joint : permet de maintenir le trombone dans la liste des mails

    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
 
    Dim f As Integer
    Dim Fichier As String
    Dim ListePJ As String
    
    Dim ListeEnPJ, InsertMention As Boolean
    
    Set Courrier = MailActif
    If Courrier Is Nothing Then Exit Sub
    
    NbPJ = Courrier.Attachments.Count
    If NbPJ = 0 Then
        MsgBox "Le messages en cours ne contient pas de pièce jointe.", vbInformation
        Exit Sub
    End If
    
    ' Decommenter pour ajouter une confirmation si on supprime les suivantes
    'If MsgBox("Vous êtes sur le point de supprimer les pièces jointes de ce message." & vbCrLf & "Continuer ?", _
    '    vbYesNo + vbQuestion, "Suppression des pièces jointes...") = vbNo Then Exit Sub
   
    ListeEnPJ = True
    'Commenter ou supprimer pour ne pas poser la question
    If MsgBox("Ajouter un fichier texte mentionnant la liste des pièces jointes intiales.", _
        vbYesNo + vbQuestion, "Ajout fichier joint...") = vbNo Then ListeEnPJ = False
    
    InsertMention = True
    'Commenter ou supprimer pour ne pas poser la question
    If MsgBox("Mentionner la liste des pièces jointes dans le corps du message ?", _
        vbYesNo + vbQuestion, "Mentionner les pièces jointes dans le message...") = vbNo Then InsertMention = False

    If ListeEnPJ = False And InsertMention = False Then
        MsgBox "Opération annulée." & vbCrLf & "Les pièces jointes n'ont pas été supprimées", vbInformation, "Opération annulée..."
        Exit Sub
    End If
    
    Select Case Courrier.BodyFormat
        Case olFormatHTML:
            Separateur = "<br/>"
            NbTiret = 45
        Case olFormatPlain:
            Separateur = Chr(10)
            NbTiret = 35
        Case Else
            Separateur = " - "
            NbTiret = 50
    End Select

    NomsPJ = IIf(NbPJ = 1, "Pièce jointe", "Pièces jointes") & " du message initial : " & Separateur & String(NbTiret, "-")
    ListePJ = IIf(NbPJ = 1, "Pièce jointe", "Pièces jointes") & " du message initial :" & vbCrLf _
    & String(IIf(NbPJ = 1, 33, 35), "-") & vbCrLf & vbCrLf

    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
            ListePJ = ListePJ & "- " & PJ.FileName & vbCrLf
            PJ.Delete
        End If
        
    Next

    If Not ListeEnPJ Then GoTo InsererMention
    
    If Dir("c:\temp\", vbDirectory) = "" Then
        MsgBox "Le dossier temporaire ""c:\temp\"" n'existe pas." & vbCrLf & "Procédure annulée.", vbCritical
        Exit Sub
    End If

    Fichier = "c:\temp\" & IIf(NbPJ = 1, "Pièce jointe", "Pièces jointes") & ".txt"
    
    If Dir(Fichier) <> "" Then
        If MsgBox("Le fichier """ & Fichier & """ existe déjà." & vbCrLf & "Ecraser le fichier ?", vbQuestion Or vbYesNo) = vbNo Then
            MsgBox "Procédure annulée.", vbInformation
            Exit Sub
        End If
    End If
        
    f = FreeFile
    Open Fichier For Output As #f
        Print #f, ListePJ
    Close #f
    
    Courrier.Attachments.Add Fichier
    
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set fic = fs.GetFile(Fichier)
    fic.Delete
    Set fic = Nothing
    Set fs = Nothing

InsererMention:
    If InsertMention Then
    
        Select Case Courrier.BodyFormat
            Case olFormatHTML:
                Courrier.HTMLBody = "<font style='font-family: Arial ;font-size: 8pt ;color:#808080;font-style: italic;'>" _
                    & NomsPJ & "</font><br/>" & "<font style='font-family: Arial ;font-size: 8pt ;color:#808080;font-style: italic;'>" _
                    & String(NbTiret, "-") & "</font><br/><br/>" & Courrier.HTMLBody
            Case Else
                Courrier.Body = NomsPJ & Chr(10) & String(NbTiret, "-") & Chr(10) & Chr(10) & Courrier.Body
        
        End Select
    End If
    
    ' La demande d'enregistrement est effectuées à la fermeture du mail
    ' Décommenter la ligne suivante pour enregistrer automatiquement les modifs sans demande de confirmation
    'Courrier.Save
    
End Sub

 

La mise en forme du code VBA a été effectuée en partie grâce au travail de Michel Gaboly

 


Publié par Oliv le vendredi 23 mars 2007 12:22 0 Commentaires 15740 Lecture(s) Imprimer
Commentaires
les commentaires sont fermés.
Copyright et partage
Ce site est sous licence Creative Commons.
Vous pouvez utiliser toutes les informations présentent ici, mais il vous est interdit de les reproduire sans citer la source.

Creative Commons License
OUI au partage
NON au « copillage »

Ajouter aux favoris / partager : 
URL :
BBcode :
HTML :
Cliquez ci dessus sur le lien que vous voulez copier et [Ctrl] + [C] ou cliquez sur le bouton [ C ]
Articles similaires
Articles Catégories
R06032 Utiliser l'archivage automatique avec les dates de réception Q06000 Les fichiers d'Outlook
R15045 [VBA] Ouvrir l'arborescence des pst contenant une boîte de réception Q15000 Macros - VBA
R15930 [VBA] Création de menu dans outlook Q15000 Macros - VBA
R17070 VSTO et les formulaires d'Outlook 2007 Q17000 Formulaires
R15380 [VBA] Envoi via VBA : suppression de la confirmation d'envoi Q15000 Macros - VBA
Nuage de tags
R16050 Importer d'un autre PC les courriels d'Outlook Express vers Outlook sous Vista, R08210 Message d'erreur : Le client de courrier électronique par défaut n'est pas correctement installé, R99460 Vous hésitez encore ?, R11050 Restaurer ses paramètres de compte de messagerie, R03090 Rechercher les messages d'un même auteur, R06080 Créer rapidement une règle selon un message, R08010 Débloquer la boite d'envoi, R04040 Imprimer directement une pièce jointe, R10030 Exporter tout ou partie du fichier .PST, R10005 Copier le PST, R05040 Imprimer la partie utile d'un message, R14060 Gérer vos Notes, R15900 [VBA] Relever des boites pop sequentiellement (FREE), R15220 [VBA] Supprimer les Pièces jointes., R20020 Configurer un compte IMAP pour Outlook 2002/2003

aucun Crack, CrackZ, no-CD, DownloadZ, TelechargementZ, Serial, Numéro de série, N0 de série, Serialz ni Keygen pour Outlook sur ce site.

Blague aléatoire
Publicité
Météo Marseille
[/\] Copyright JièL / Jean-Louis Goubert © 2003-2009 [/\]