Mardi 11 Août 2020  
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 : 3
Membres en ligne : 0

 JièL 15 semaines
 manucau 17 semaines
 Manu-pb 18 semaines
 Oliv 23 semaines
 pirobert 64 semaines
 jcgdisle 89 semaines
 EMERGENCY 110 semaines
 beaulieu 122 semaines
 callaghi 126 semaines
 Charlie76 131 semaines

Non activés :0

Nombre de visiteurs
depuis le : 12/11/2008

Aujourd'hui:472
En ligne :3
Max. en ligne:312
Max. / jour:66 529
Total hier:1 783
Total ce mois:23 009
Total visites:23 891 789
Moyenne/jour:5 570

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 19183 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
R08210 Message d'erreur : Le client de courrier électronique par défaut n'est pas correctement installé, R09050 Supprimer TOUS les noms suggérés lors de la saisie d'adresses (saisie auto ou saisie semi auto), R06040 Paramétrer l'archivage automatique d'un dossier, R00110 Vérifier une adresse mail avant d'envoyer un message, R07090 Supprimer / Modifier un expéditeur indésirable de la liste, R12055 Planifier une réunion, R02050 Lancer Outlook au démarrage Windows, R15100 [VBA] Imprimer les destinataires CCI, R09060 La case « Afficher ... comme carnet d'adresses... » est grisée, R11070 Restaurer les fichiers de paramètres d'Outlook, R08110 Ouvrir un autre PST, R11040 Restaurer ses règles de gestion des messages, R07025 Lancer Outlook plusieurs fois avec plusieurs profils, R10050 Sauvegarder ses paramètres de compte messagerie, R15040 [VBA] Parcourir tous les dossiers et sous-dossiers.

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é
[/\] Copyright JièL / Jean-Louis Goubert © 2003-2009 [/\]