Lundi 20 Mai 2019  
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 : 1
Membres en ligne : 0

 pirobert 5 jours
 jcgdisle 25 semaines
 EMERGENCY 46 semaines
 beaulieu 58 semaines
 callaghi 61 semaines
 Charlie76 67 semaines
 joscopp 78 semaines
 JièL 78 semaines
 julbast 78 semaines
 zorro71 103 semaines

Non activés :0

Nombre de visiteurs
depuis le : 12/11/2008

Aujourd'hui:30
En ligne :1
Max. en ligne:312
Max. / jour:66 529
Total hier:3 732
Total ce mois:104 405
Total visites:21 769 070
Moyenne/jour:5 669

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 »  [>>]
R15280 [VBA] Exporter un mail et l'ouvrir dans IE avec ses images

Cette macro permet donc d'ouvrir un mail en HTML dans INTERNET EXPLORER avec ses images incorporées s'il en a, enregistrant dans un dossier ici c:\temp\edi\


Il faut lancer ou créer un bouton sur SaveAsHtmlFileWithEmbedded

 

Option Explicit
' ajouter une référence à Microsoft CDO 1.21 library
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
 
Public oSession As MAPI.Session
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Const OLECMDEXECOPT_DODEFAULT = 0, OLECMDEXECOPT_PROMPTUSER = 1, OLECMDEXECOPT_DONTPROMPTUSER = 2, OLECMDEXECOPT_SHOWHELP = 3
Const OLECMDID_OPEN = 1, OLECMDID_NEW = 2, OLECMDID_SAVE = 3, OLECMDID_SAVEAS = 4, OLECMDID_SAVECOPYAS = 5, OLECMDID_PRINT = 6, OLECMDID_PRINTPREVIEW = 7, OLECMDID_PAGESETUP = 8, OLECMDID_SPELL = 9, OLECMDID_PROPERTIES = 10, OLECMDID_CUT = 11, OLECMDID_COPY = 12, OLECMDID_PASTE = 13, OLECMDID_PASTESPECIAL = 14, OLECMDID_UNDO = 15, OLECMDID_REDO = 16, OLECMDID_SELECTALL = 17, OLECMDID_CLEARSELECTION = 18, OLECMDID_ZOOM = 19, OLECMDID_GETZOOMRANGE = 20, _
OLECMDID_UPDATECOMMANDS = 21, OLECMDID_REFRESH = 22, OLECMDID_STOP = 23, OLECMDID_HIDETOOLBARS = 24, OLECMDID_SETPROGRESSMAX = 25, OLECMDID_SETPROGRESSPOS = 26, OLECMDID_SETPROGRESSTEXT = 27, OLECMDID_SETTITLE = 28, OLECMDID_SETDOWNLOADSTATE = 29, OLECMDID_STOPDOWNLOAD = 30, OLECMDID_ONTOOLBARACTIVATED = 31, OLECMDID_FIND = 32, OLECMDID_DELETE = 33, OLECMDID_HTTPEQUIV = 34, OLECMDID_HTTPEQUIV_DONE = 35, OLECMDID_ENABLE_INTERACTION = 36, OLECMDID_ONUNLOAD = 37, OLECMDID_PROPERTYBAG2 = 38, OLECMDID_PREREFRESH = 39, OLECMDID_SHOWSCRIPTERROR = 40, OLECMDID_SHOWMESSAGE = 41, OLECMDID_SHOWFIND = 42, OLECMDID_SHOWPAGESETUP = 43, OLECMDID_SHOWPRINT = 44, OLECMDID_CLOSE = 45, OLECMDID_ALLOWUILESSSAVEAS = 46, _
OLECMDID_DONTDOWNLOADCSS = 47, OLECMDID_UPDATEPAGESTATUS = 48, OLECMDID_PRINT2 = 49, OLECMDID_PRINTPREVIEW2 = 50, OLECMDID_SETPRINTTEMPLATE = 51, OLECMDID_GETPRINTTEMPLATE = 52, OLECMDID_PAGEACTIONBLOCKED = 55, OLECMDID_PAGEACTIONUIQUERY = 56, OLECMDID_FOCUSVIEWCONTROLS = 57, OLECMDID_FOCUSVIEWCONTROLSQUERY = 58, OLECMDID_SHOWPAGEACTIONMENU = 59, OLECMDID_ADDTRAVELENTRY = 60, OLECMDID_UPDATETRAVELENTRY = 61, OLECMDID_UPDATEBACKFORWARDSTATE = 62, OLECMDID_OPTICAL_ZOOM = 63, OLECMDID_OPTICAL_GETZOOMRANGE = 64, OLECMDID_WINDOWSTATECHANGED = 65
 
Private Const maxTime = 10 ' in seconds
Private Const sleepTime = 250 ' in milliseconds
 
 
 
Function remplaceCaracteresInterdit(ByVal CheminStr As String)
Dim ObjCurrentMessage As Outlook.MailItem

Dim liste As Variant
Dim L
liste = Array("\", "/", ":", "*", "?", "<", ">", "|", ".", """", vbTab, Chr(7))
For L = 0 To UBound(liste)
CheminStr = Replace(CheminStr, liste(L), "")
Next L
remplaceCaracteresInterdit = CheminStr
'MsgBox CheminStr
End Function
 
 
' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function VerifAttachtype(ByVal StrEntryID As String, attindex As Integer) As Variant
 
' CDO objects
Dim oMsg As MAPI.Message
Dim oAttachs As MAPI.Attachments
Dim oAttach As MAPI.Attachment
On Error Resume Next
' 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)
 
VerifAttachtype = strCID
Set oMsg = Nothing
Set oAttachs = Nothing
Set oAttach = Nothing
 
End Function
 
 
Sub SaveAsHtmlFileWithEmbedded()
'By oliv Fev 2007
 
Dim colAttach As Outlook.Attachments
Dim Sujet, ObjCurrentMessage, Destinataire, Repertoire, strName
Dim OLDhtml
Dim StrEntryID
Dim ENVOYEUR, ShortStrname, ImprimanteParDefaut, c, OutputFilename
On Error Resume Next
If ObjCurrentMessage Is Nothing Then
Set ObjCurrentMessage = ActiveInspector.CurrentItem
End If
On Error GoTo 0
Set colAttach = ObjCurrentMessage.Attachments
If ObjCurrentMessage.BodyFormat = olFormatHTML Then
Sujet = ObjCurrentMessage.ConversationIndex
 
If ObjCurrentMessage.ReceivedByName = "" Then
Destinataire = ObjCurrentMessage.To
Else
Destinataire = ObjCurrentMessage.ReceivedByName
End If
If ObjCurrentMessage.SenderEmailAddress = "" Then
ENVOYEUR = "Brouillon"
Else
ENVOYEUR = ObjCurrentMessage.SenderEmailAddress
End If
 
Sujet = Trim(Replace(Replace(remplaceCaracteresInterdit(" De " & ENVOYEUR & " Le " & Replace(Replace(ObjCurrentMessage.ReceivedTime, ":", "h", 1, 1), ":", "'") & " A " & Destinataire), " - Gras Savoye Ricour", ""), "O=RICOUROU=ASSURANCESCN=RECIPIENTSCN=", ""))
If Sujet = "" Then Sujet = ObjCurrentMessage.EntryID
 
'on crée le repertoire où mettre les fichiers joints ##########################################################
If Repertoire = "" Then Repertoire = "c:\temp\Email\" & Sujet & "\"
If "" = Dir("c:\temp\Email\", vbDirectory) Then MkDir "c:\temp\Email\"
 
If Repertoire <> "" Then
If "" = Dir("c:\temp\", vbDirectory) Then MkDir "c:\temp\"
 
If "" = Dir("c:\temp\Email\", vbDirectory) Then MkDir "c:\temp\Email\"
 
If "" = Dir(Repertoire, vbDirectory) Then MkDir Repertoire
End If
 
 
If "" = Dir(Repertoire & "embedded\", vbDirectory) Then MkDir Repertoire & "embedded\"
 
End If
'=======================================================================
'On boucle sur les pj pour enlever le cid et enregistrer la pj
'=======================================================================
OLDhtml = ObjCurrentMessage.HTMLBody
 
' initialize CDO session
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
On Error GoTo 0
 
StrEntryID = ObjCurrentMessage.EntryID
Dim i, toto
For i = 1 To colAttach.Count
toto = VerifAttachtype(StrEntryID, colAttach(i).index)
If toto <> "" Then
'MsgBox "type:=" & toto & vbCr & " Piece:= " & colAttach(i).FileName
ObjCurrentMessage.HTMLBody = Replace(ObjCurrentMessage.HTMLBody, "cid:" & toto, "embedded\" & colAttach(i).FileName)
colAttach(i).SaveAsFile Repertoire & "embedded\" & colAttach(i).FileName
End If
Next i
 
oSession.Logoff
Set oSession = Nothing
 
'=======================================================================
'on enregistre le mail
'=======================================================================
DoEvents
ShortStrname = "Email " & Left(remplaceCaracteresInterdit(Sujet), 160)
strName = Repertoire & ShortStrname
ObjCurrentMessage.SaveAs strName & ".htm", OlSaveAsType.olHTML
ObjCurrentMessage.HTMLBody = OLDhtml
DoEvents
ObjCurrentMessage.Display
 
 
 
Dim ExpShell As Object
Dim Cmdshell, cmdshell1, resultat
Set ExpShell = CreateObject("WScript.Shell")
 
Cmdshell = "explorer " & Repertoire
cmdshell1 = "explorer " & strName & ".htm"
resultat = ExpShell.Run(Cmdshell, 1, False)
 
controlIE strName & ".htm"
'=======================================================================
'Fin on nettoie
'=======================================================================
On Error Resume Next
 
Repertoire = ""
Sujet = ""
StrEntryID = ""
 
Set ObjCurrentMessage = Nothing
Set ExpShell = Nothing
MsgBox "Pensez à supprimer les fichiers une fois terminé dans C:\TEMP\Email", vbOKOnly, "Export terminé"
 
 
 
Set colAttach = Nothing
 
 
End Sub
 
Private Sub controlIE(strName As String)
Dim ie As Object
Set ie = CreateObject("internetexplorer.application")
ie.Visible = True
ie.navigate (strName)
Do While ie.Busy
DoEvents
Loop
End Sub

Publié par Oliv le lundi 16 février 2009 18:18 0 Commentaires 18503 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
R12120 Synchroniser Google Calendar avec Outlook 2010 Q12000 Calendrier
R10095 Utiliser PFBACKUP avec Outlook 2010 Q10000 Sauvegarde
Nuage de tags
R08240 Pourquoi la désinstallation/Réinstallation ne fait rien ?!, R03120 Insérer du HTML dans un message, R00090 Noms des serveurs POP, IMAP, SMTP et Webmail des principaux FAI, R05080 Les en-têtes des mails (les destinataires, la date...) ne s'impriment pas, R11070 Restaurer les fichiers de paramètres d'Outlook, R99180 Matériel spécial, R01110 Créer un modèle de message (pas un papier peint), R15410 [VBA] Remplacer dans les Contacts l'envoi au format RTF, R99040 Drag and Drop, R06005 Emplacements des différents fichiers d'Outlook, R15045 [VBA] Ouvrir l'arborescence des pst contenant une boîte de réception, R17070 VSTO et les formulaires d'Outlook 2007, R12100 Partager son calendrier, R06080 Créer rapidement une règle selon un message, R08070 Réparer / remettre en état Outlook ou le PST (6 solutions à appliquer dans l'ordre)

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 [/\]