Hello,
I want to save Email as HTML file with embedded pictures.
First i update HTMLBODY to change cid: to attachment.filename

It's ok but i need the line
MsgBox "Save in progress"
else the html file is not update.

I don't know why ?

Thank you

--
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Have a nice day
Oliv'
Outlook : http://faq.outlook.free.fr/
les archives : http://groups.google.com/group/micro...lic.fr.outlook
Dernière chance http://www.outlookcode.com/
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


Sub IsEmbedded()
Dim objCurrentMessage As Outlook.MailItem
Dim colAttach As Outlook.Attachments
Dim Sujet
Dim OLDhtml
Dim strEntryID
Set objCurrentMessage = ActiveInspector.CurrentItem
Set colAttach = objCurrentMessage.Attachments

Sujet = objCurrentMessage.ConversationIndex
Sujet =
Replace(Replace(Replace(Replace(Replace(Replace(Re place(Replace(Replace(Replace(Replace(objCurrentMe ssage.SenderEmailAddress
& objCurrentMessage.ReceivedTime & objCurrentMessage.ReceivedByName, "\",
""), "/", ""), ":", ""), "*", ""), "?", ""), "", ""), "", ""), "|", ""),
".", ""), """", ""), " - Gras Savoye Ricour", "")
If Sujet = "" Then Sujet = objCurrentMessage.EntryID
'on crée le repertoire où mettre les fichiers joints
################################################## ########
repertoire = "c:\temp\Email\" & Sujet & "\"
If "" = Dir("c:\temp\Email\", vbDirectory) Then
MkDir "c:\temp\Email\"
End If

If repertoire "" Then
If "" = Dir(repertoire, vbDirectory) Then
MkDir repertoire
End If
If "" = Dir(repertoire & "embedded\", vbDirectory) Then
MkDir repertoire & "embedded\"
End If
End If
'================================================= ================
'On boucle sur les pj pour enlever le cid et enregistrer la pj
'================================================= ================
OLDhtml = objCurrentMessage.HTMLBody

strEntryID = objCurrentMessage.EntryID
Dim i, toto
For i = 1 To colAttach.Count
toto = Attachtype(strEntryID, colAttach(i).index)
'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
Next i

'================================================= ================
'on enregistre le mail
'================================================= ================
objCurrentMessage.Save
objCurrentMessage.Display
'Sleep 5000
MsgBox "Save in progress"
strname = repertoire & "Email " &
Left(Replace(Replace(Replace(Replace(Replace(Repla ce(Replace(Replace(Replace(Replace(Replace(Replace (Sujet,
"\", ""), "/", ""), ":", ""), "*", ""), "?", ""), "", ""), "", ""), "|",
""), ".", ""), """", ""), vbTab, ""), Chr(7), ""), 160)
objCurrentMessage.SaveAs strname & ".htm", OlSaveAsType.olHTML
objCurrentMessage.HTMLBody = OLDhtml
objCurrentMessage.Save

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)
resultat = ExpShell.Run(cmdshell1, 1, False)
'Shell cmdshell, vbMaximizedFocus

'cmdshell = "explorer " & repertoire
'Shell cmdshell, vbMaximizedFocus
'================================================= ================
'Fin on nettoie
'================================================= ================
On Error Resume Next
'Kill (repertoire & "*.*")
'RmDir (repertoire)
repertoire = ""
Sujet = ""
strEntryID = ""
Set objCurrentMessage = Nothing
Set colAttach = Nothing
Set ExpShell = Nothing
'Attente.Repaint
'Unload Attente
End Sub

' Function: Fields_Selector
' Purpose: View type of attachment
' olivier catteau fevrier 2006
Function Attachtype(ByVal strEntryID As String, attindex As Integer) As
Variant

Dim oSession As MAPI.Session
' CDO objects
Dim oMsg As MAPI.Message
Dim oAttachs As MAPI.Attachments
Dim oAttach As MAPI.Attachment

' initialize CDO session
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False

' 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)

Attachtype = strCID
Set oMsg = Nothing
oSession.Logoff
Set oSession = Nothing
End Function