Lundi 18 Juin 2018  
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 : 7
Membres en ligne : 0

 beaulieu 10 semaines
 callaghi 13 semaines
 EMERGENCY 17 semaines
 Charlie76 19 semaines
 joscopp 30 semaines
 JièL 30 semaines
 julbast 30 semaines
 pirobert 31 semaines
 zorro71 55 semaines
 Alphator 73 semaines

Non activés :0

Nombre de visiteurs
depuis le : 12/11/2008

Aujourd'hui:2 071
En ligne :6
Max. en ligne:312
Max. / jour:66 529
Total hier:4 624
Total ce mois:70 721
Total visites:19 962 812
Moyenne/jour:5 697

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 17933 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
R01100 Lire un message sans envoyer la confirmation de lecture, R07080 Ajouter un expéditeur indésirable, R06090 Appliquer une règle aux messages existants, R02010 Connexion / Déconnexion automatique à Internet, R17010 Impossible d'exporter les données de champs personnalisés, R00020 Mettre Outlook 2002 (et autres) dans le systray, R03120 Insérer du HTML dans un message, R10030 Exporter tout ou partie du fichier .PST, R12100 Partager son calendrier, R01070 Changer définitivement l'adresse de retour d'un compte, R03040 Choisir un papier à lettres pour un message, R15240 [VBA] Viewer de pièces jointes., R01070 Changer définitivement l'adresse de retour d'un compte, R06060 Créer un dossier (sous dossier) dans le .PST, R16040 Importer le carnet d'adresses d'Outlook Express dans Outlook

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