Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
Bonjoir(c) Oliv'je viens d'écrire un truc dans ce genre pour outlook 2003 avec
lancement par un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent
site http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
Beau travail!!!
Si je peux me permettre, n'est il pas possible d'utiliser la fonction
de compression de Windows afin de rendre ce prog parfaitement intégré
?
Bonjoir(c) Oliv'
je viens d'écrire un truc dans ce genre pour outlook 2003 avec
lancement par un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent
site http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
Beau travail!!!
Si je peux me permettre, n'est il pas possible d'utiliser la fonction
de compression de Windows afin de rendre ce prog parfaitement intégré
?
Bonjoir(c) Oliv'je viens d'écrire un truc dans ce genre pour outlook 2003 avec
lancement par un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent
site http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
Beau travail!!!
Si je peux me permettre, n'est il pas possible d'utiliser la fonction
de compression de Windows afin de rendre ce prog parfaitement intégré
?
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
..
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un ' devant les
lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très interessantes pour
différencier les images insérées au sein des pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments, objCurrentMessage As
MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP" Then
MsgBox " [" & objAtt.FileName & "] est une image insérée ou est déjà
un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index devant le
nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?", "euro")
liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip c:tempziptemp" &
ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main qu'une
fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP" Then
objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded & "
document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le signaler à
Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer) As
Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
--
--
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Have a nice day
Oliv'
Pour me joindre : http://cerbermail.com/?V8r2o1YHl4
les sites références:
Excel :http://www.excelabo.net http://xcell05.free.fr/
http://dj.joss.free.fr/
http://frederic.sigonneau.free.fr/ http://www.excel-vba-francais.com/
Word : http://faqword.free.fr/
Outlook :http://faq.outlook.free.fr/
Sql :http://sqlpro.developpez.com/
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
..
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un ' devant les
lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très interessantes pour
différencier les images insérées au sein des pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments, objCurrentMessage As
MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP" Then
MsgBox " [" & objAtt.FileName & "] est une image insérée ou est déjà
un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index devant le
nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?", "euro")
liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip c:tempziptemp" &
ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main qu'une
fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP" Then
objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded & "
document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le signaler à
Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer) As
Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
--
--
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Have a nice day
Oliv'
Pour me joindre : http://cerbermail.com/?V8r2o1YHl4
les sites références:
Excel :http://www.excelabo.net http://xcell05.free.fr/
http://dj.joss.free.fr/
http://frederic.sigonneau.free.fr/ http://www.excel-vba-francais.com/
Word : http://faqword.free.fr/
Outlook :http://faq.outlook.free.fr/
Sql :http://sqlpro.developpez.com/
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
..
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un ' devant les
lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très interessantes pour
différencier les images insérées au sein des pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments, objCurrentMessage As
MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP" Then
MsgBox " [" & objAtt.FileName & "] est une image insérée ou est déjà
un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index devant le
nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?", "euro")
liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip c:tempziptemp" &
ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main qu'une
fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP" Then
objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded & "
document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le signaler à
Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer) As
Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
--
--
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Have a nice day
Oliv'
Pour me joindre : http://cerbermail.com/?V8r2o1YHl4
les sites références:
Excel :http://www.excelabo.net http://xcell05.free.fr/
http://dj.joss.free.fr/
http://frederic.sigonneau.free.fr/ http://www.excel-vba-francais.com/
Word : http://faqword.free.fr/
Outlook :http://faq.outlook.free.fr/
Sql :http://sqlpro.developpez.com/
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec
lancement par un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent
site http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un '
devant les lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très
interessantes pour différencier les images insérées au sein des
pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments,
objCurrentMessage As MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP"
Then MsgBox " [" & objAtt.FileName & "] est une image insérée
ou est déjà un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index
devant le nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?",
"euro") liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip
c:tempziptemp" & ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main
qu'une fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP"
Then objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded
& " document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le
signaler à Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer)
As Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
--
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec
lancement par un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent
site http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un '
devant les lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très
interessantes pour différencier les images insérées au sein des
pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments,
objCurrentMessage As MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP"
Then MsgBox " [" & objAtt.FileName & "] est une image insérée
ou est déjà un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index
devant le nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?",
"euro") liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip
c:tempziptemp" & ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main
qu'une fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP"
Then objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded
& " document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le
signaler à Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer)
As Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
--
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec
lancement par un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent
site http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
.
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un '
devant les lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très
interessantes pour différencier les images insérées au sein des
pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments,
objCurrentMessage As MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP"
Then MsgBox " [" & objAtt.FileName & "] est une image insérée
ou est déjà un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index
devant le nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?",
"euro") liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip
c:tempziptemp" & ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main
qu'une fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP"
Then objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded
& " document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le
signaler à Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer)
As Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
--
Si je peux me permettre, n'est il pas possible d'utiliser la fonction
de compression de Windows afin de rendre ce prog parfaitement intégré
?
Si je peux me permettre, n'est il pas possible d'utiliser la fonction
de compression de Windows afin de rendre ce prog parfaitement intégré
?
Si je peux me permettre, n'est il pas possible d'utiliser la fonction
de compression de Windows afin de rendre ce prog parfaitement intégré
?
Tous mes remerciements Olivier !
Cependant, au risque de paraitre ennuyeux, il s'avère que je ne sais pas
du
tout que faire avec ces éléments que tu viens de me communiquer, étant,
pour
ainsi dire, une sorte "d'utilisateur final".
En espérant ne pas trop abuser de ton temps,
DavidBonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement
par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
..
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un ' devant
les
lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très interessantes
pour
différencier les images insérées au sein des pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments, objCurrentMessage
As
MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP" Then
MsgBox " [" & objAtt.FileName & "] est une image insérée ou est
déjà
un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index devant
le
nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?",
"euro")
liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip c:tempziptemp"
&
ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main
qu'une
fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP" Then
objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded &
"
document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le signaler
à
Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer) As
Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
Tous mes remerciements Olivier !
Cependant, au risque de paraitre ennuyeux, il s'avère que je ne sais pas
du
tout que faire avec ces éléments que tu viens de me communiquer, étant,
pour
ainsi dire, une sorte "d'utilisateur final".
En espérant ne pas trop abuser de ton temps,
David
Bonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement
par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
..
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un ' devant
les
lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très interessantes
pour
différencier les images insérées au sein des pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments, objCurrentMessage
As
MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP" Then
MsgBox " [" & objAtt.FileName & "] est une image insérée ou est
déjà
un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index devant
le
nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?",
"euro")
liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip c:tempziptemp"
&
ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main
qu'une
fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP" Then
objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded &
"
document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le signaler
à
Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer) As
Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
Tous mes remerciements Olivier !
Cependant, au risque de paraitre ennuyeux, il s'avère que je ne sais pas
du
tout que faire avec ces éléments que tu viens de me communiquer, étant,
pour
ainsi dire, une sorte "d'utilisateur final".
En espérant ne pas trop abuser de ton temps,
DavidBonjour,
Notre entreprise tourne sous Outlook 2000 et dans le cadre de notre
activité nous recevons de très nombreux mails contenant des pièces
jointes par jours.
Je recherche un moyen de sauvegarder les pièces jointes d'un mail
particulier au sein d'un seul et même fichier d'archives ZIP. Par
exemple par le biais d'un add-on qui afficherait sur l'interface de
lecture du mail un bouton dédié à cet effet.
J'avais trouvé sur le net "Outlook Attachment Sniffer" mais ce
logiciel, bien que très complet, n'offre pas la fonction que je
recherche. En effet, il gère le traitement par lot des mails, et pas
la gestion au cas par cas.
Je vous en remercie par avance.
je viens d'écrire un truc dans ce genre pour outlook 2003 avec lancement
par
un icone
avec notamment l'aide de sources de Sue Mosher et de son excellent site
http://www.outlookcode.com/ et de bastanu sur www.vbforums.com
..
il faut 7zip sur www.7-zip.org
un formulaire nommé "attente" pour faire patienter ou mettre un ' devant
les
lignes concernées.
un repertoire "c:temp"
confirmer à la fermeture l'enregistrement
ca marche sur les nouveau mail et les mails déjà recus ou envoyés.
Pour parfaire le tout tu peux ajouter cette macro avec un test sur la
taille du mail dans l'evenement application_itemsend .
La fonction Attachtype a également des utilisations très interessantes
pour
différencier les images insérées au sein des pièces jointes.
Voici donc ma contribution !!!
MERCI DE ME FAIRE REMONTER SON UTILISATION ET SES BUG EVENTUELS
' zip les pieces jointes du mail
Sub ZIP()
' création OLIVIER CATTEAU 2006
On Error Resume Next
Load Attente
Attente.Label2 = "ETAPE 1/3"
Dim liste
'parcours des fichiers attachés
################################################################################
Dim objAtt As Attachment, objAtts As Attachments, objCurrentMessage
As
MailItem
If Application.ActiveInspector Is Nothing Then GetSelectedItems
Set objCurrentMessage = ActiveInspector.CurrentItem
Set objAtts = objCurrentMessage.Attachments
nb_attach = objAtts.Count
If nb_attach = 0 Then
erreur = "Pas de fichiers joints"
GoTo fin
End If
Attente.Show vbModeless
On Error GoTo 0
'on crée le repertoire où mettre les fichiers joints
##########################################################
repertoire = "c:tempziptemp" & ""
If repertoire <> "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
Else
On Error Resume Next
Kill repertoire & "*.*"
On Error GoTo 0
End If
End If
'#################################Traitement des fichiers joints
###################################################
'liste = ""
Dim strEntryID As String
If objCurrentMessage.EntryID = "" Then objCurrentMessage.Save
strEntryID = objCurrentMessage.EntryID
For Each objAtt In objAtts
typeatt = Attachtype(strEntryID, objAtt.index)
If typeatt <> "" Or UCase(Right(objAtt.FileName, 3)) = "ZIP" Then
MsgBox " [" & objAtt.FileName & "] est une image insérée ou est
déjà
un ZIP" & vbCr & " cette pièce ne sera pas zippée"
nb_embedded = nb_embedded + 1
Else
'ajoutter un controle dir sur le fichier et mettre l'index devant
le
nom pour les doublons
objAtt.SaveAsFile repertoire & Replace(objAtt.FileName, "?",
"euro")
liste = liste & "{" & objAtt.FileName & "}"
End If
Next
' zippe les documents
If nb_attach > nb_embedded Then
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
On Error Resume Next
ExistDoc = nb_attach - nb_embedded & "documents.zip"
If ExistDoc <> objAtts(ExistDoc) Then
ExistDoc = nb_attach - nb_embedded & "documents.zip"
Else
ExistDoc = "documents.zip"
End If
On Error GoTo 0
tacommande = """C:Program Files7-Zip7za"" a -tzip c:tempziptemp"
&
ExistDoc & " " & repertoire & "*.*"
' pour volume multiple si + 2 mo
'TaCommande = """C:Program Files7-Zip7za"" a -tzip -v2m
c:tempziptempdocuments.zip " & repertoire & "*.*"
resultat = objShell.Run(tacommande, 1, True) ' ne rendra la main
qu'une
fois terminé
If resultat = 0 Then
'supprime les pieces jointes
Do While objAtts.Count > nb_embedded ' Boucle interne.
For Each truc In objAtts
typeatt = Attachtype(strEntryID, truc.index)
If typeatt = "" And UCase(Right(truc.FileName, 3)) <> "ZIP" Then
objAtts.Remove (truc.index)
Exit For ' Quitte la boucle interne.
End If
Next truc
Loop
'méthode pour tout supprimer.
'While objAtts.Count > 0
'objAtts.Remove 1
'Wend
objAtts.Add Source:="c:tempziptemp" & ExistDoc, Type:=olByValue
liste = "[Contenu de " & ExistDoc & " : " & nb_attach - nb_embedded &
"
document(s) :<br>" & liste & "]<br>"
If objAtts.Parent.BodyFormat = olFormatHTML Then
objAtts.Parent.HTMLBody = "<HTML>" & liste & "<br>" &
objCurrentMessage.HTMLBody
Else: objCurrentMessage.Body = Replace(liste, "<br>", vbCr) &
objCurrentMessage.Body
End If
'supprimes mes fichiers temporaires
On Error Resume Next
Kill repertoire & "*.*"
Set objShell = Nothing
Else: erreur = "erreur de compression " & vbCr & "Merci de le signaler
à
Olivier"
End If
End If
fin:
On Error Resume Next
If erreur <> "" Then
MsgBox erreur, vbCritical, "Fin de traitement"
Else
'MsgBox "Traitement terminé"
End If
Attente.Label2 = "Terminé"
Attente.Repaint
Unload Attente
Set resultat = Nothing
Set erreur = Nothing
Set objCurrentMessage = Nothing
Set objAtts = Nothing
Set nb_attach = Nothing
Set tacommande = Nothing
Set liste = Nothing
End Sub
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer) As
Variant
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 <IMG> tag
Set oAttachs = oMsg.Attachments
Set oAttach = oAttachs.Item(attindex)
Dim strCID As String
strCID = oAttach.Fields(&H3712001E)
Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function
Bonjour Oliv',
Super merci pour ta participation ...
... mais je bloque rapidement à l'utilisation.
lorsque je lance la macro, j'ai un message comme quoi la sub ou function
n'est pas définie sur "If Application.ActiveInspector Is Nothing Then
GetSelectedItems" (c'est GetSelectedItems qui est surligné) ...
voir ma réponse à David
Bonjour Oliv',
Super merci pour ta participation ...
... mais je bloque rapidement à l'utilisation.
lorsque je lance la macro, j'ai un message comme quoi la sub ou function
n'est pas définie sur "If Application.ActiveInspector Is Nothing Then
GetSelectedItems" (c'est GetSelectedItems qui est surligné) ...
voir ma réponse à David
Bonjour Oliv',
Super merci pour ta participation ...
... mais je bloque rapidement à l'utilisation.
lorsque je lance la macro, j'ai un message comme quoi la sub ou function
n'est pas définie sur "If Application.ActiveInspector Is Nothing Then
GetSelectedItems" (c'est GetSelectedItems qui est surligné) ...
voir ma réponse à David
Bonjour Oliv',
un mot : fabuleux
un autre mot : merci
:-)
Bonjour Oliv',
un mot : fabuleux
un autre mot : merci
:-)
Bonjour Oliv',
un mot : fabuleux
un autre mot : merci
:-)
