Samedi 21 Septembre 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 : 6
Membres en ligne : 0

 pirobert 18 semaines
 jcgdisle 43 semaines
 EMERGENCY 64 semaines
 beaulieu 75 semaines
 callaghi 79 semaines
 Charlie76 85 semaines
 joscopp 95 semaines
 JièL 96 semaines
 julbast 96 semaines
 zorro71 120 semaines

Non activés :0

Nombre de visiteurs
depuis le : 12/11/2008

Aujourd'hui:463
En ligne :6
Max. en ligne:312
Max. / jour:66 529
Total hier:7 722
Total ce mois:117 986
Total visites:22 642 718
Moyenne/jour:5 712

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 18779 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
R12120 Synchroniser Google Calendar avec Outlook 2010, R08240 Pourquoi la désinstallation/Réinstallation ne fait rien ?!, R09200 Trier les destinataires dans le carnet d'adresses (version 2000), R08090 Liste des codes d'erreurs et significations, R03040 Choisir un papier à lettres pour un message, R05045 Imprimer la partie utile d'un message (Outlook 2007 et autres), R03120 Insérer du HTML dans un message, R99095 Retrait d'argent ?, R08230 Problème avec le carnet d'adresses Outlook 2000 sous Vista, R15400 [VBA] Changer les parametres POP des COMPTES, R10010 Sauvegarder TOUT Office 2003, R09130 Rechercher dans le carnet d'adresses, R00100 Afficher les GIFs animés avec Outlook 2007, R15230 [VBA] Extraire automatiquement les pièces jointes vers un dossier Windows., R12070 Gérer les réponses à la demande de réunion

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