Lundi 21 Août 2017  
Navigation
FAQ Outlook
» Foire Aux Questions «
Recherche
Téléchargements
Forums Outlook
Plan du site
Liens
Login

Les inscriptions sont fermées

Pseudo

Mot de passe

Se souvenir de moi



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

 EMERGENCY 3 semaines
 callaghi 5 semaines
 JièL 7 semaines
 zorro71 12 semaines
 Alphator 30 semaines
 ande 36 semaines
 Oliv 38 semaines
 cubitus 41 semaines
 angel 51 semaines
 Quartzkyte 60 semaines

Non activés :0

Nombre de visiteurs
depuis le : 12/11/2008

Aujourd'hui:3 707
En ligne :2
Max. en ligne:312
Max. / jour:66 529
Total hier:4 701
Total ce mois:99 484
Total visites:18 114 779
Moyenne/jour:5 654

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 17335 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
R07090 Supprimer / Modifier un expéditeur indésirable de la liste, R15380 [VBA] Envoi via VBA : suppression de la confirmation d'envoi, R18020 Dépasser la limites de 32Ko des règles avec un serveur Exchange, R09150 Publipostage à partir des contacts d'Outlook, R03060 Créer un papier à lettres a partir d'un message reçu, R99240 Quomen pozé une kestion, R15410 [VBA] Remplacer dans les Contacts l'envoi au format RTF, R15420 [VBA] Trouver une adresse Email dans les Contacts, R14020 Recherche avancée, R20140 Configurer un compte GMAIL pour Outlook 2007, R12055 Planifier une réunion, R17010 Impossible d'exporter les données de champs personnalisés, R17020 Lecture des propriétés d'un compte exchange, R02020 Envoyer / recevoir automatiquement, R15270 [VBA] Exécuter un script sur une règle

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