save Email as HTML file with embedded pictures after udpdate HTMLbody

  • Thread starter Thread starter Oliv'
  • Start date Start date
O

Oliv'

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/microsoft.public.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(Replace(Replace(Replace(Replace(Replace(objCurrentMessage.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(Replace(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
 
Please clarify. Are you saving the Outlook item after you update the
HTMLBody? Are you calling SaveAs to update the saved MSG file?
 
*Ken Slovak - said:
Please clarify. Are you saving the Outlook item after you update the
HTMLBody?
Click to expand...
yes i update objCurrentMessage.HTMLBody (see "*1>" below
i save objCurrentMessage.save (see "*2>")
Are you calling SaveAs to update the saved MSG file?
Click to expand...

yes objCurrentMessage.saveas (see "*3>" below)
 
And is the MSG file and the original item both updated? I don't understand
the problem or why you would need a MsgBox dialog.
 
*Ken Slovak - said:
And is the MSG file and the original item both updated? I don't
understand the problem or why you would need a MsgBox dialog.
Click to expand...

Precisely, I don't want this MsgBox dialog but if it is not there export is
not good.
link to my code as .bas file http://cjoint.com/?ccmnqyrzFU if you want to
test it
you need "c:\temp" directory
Sorry my english is very bad
Oliv'
 
No, I don't download and run code from the Web, sorry.

Show the relevant piece of your code in a post here and let us see what you
are doing and also provide the message the dialog is showing so we know
what's going on.
 
*Ken Slovak - said:
No, I don't download and run code from the Web, sorry.

Show the relevant piece of your code in a post here and let us see
what you are doing and also provide the message the dialog is showing
so we know what's going on.
Click to expand...

Hello Ken
If i comment MsgBox "IN PROGRESS" the export is bad why ?
Thank you
This is my code :

Sub SaveAsHtmlFileWithEmbedded()
Dim objCurrentMessage As Outlook.MailItem
Dim colAttach As Outlook.Attachments
Dim Sujet
Dim OLDhtml
Dim strEntryID
Set objCurrentMessage = ActiveInspector.CurrentItem
Set colAttach = objCurrentMessage.Attachments
If objCurrentMessage.BodyFormat = olFormatHTML Then
Sujet = objCurrentMessage.ConversationIndex
Sujet = "mail"
'on crée le repertoire où mettre les fichiers joints
repertoire = "c:\temp\Email\" & Sujet & "\"

OLDhtml = objCurrentMessage.HTMLBody

strEntryID = objCurrentMessage.EntryID
Dim i, toto
For i = 1 To colAttach.Count
toto = Attachtype(strEntryID, colAttach(i).Index)
objCurrentMessage.HTMLBody = Replace(objCurrentMessage.HTMLBody, _
"cid:" & toto, "embedded\" & colAttach(i).FileName)
colAttach(i).SaveAsFile repertoire & "embedded\" & _
colAttach(i).FileName
Next i


objCurrentMessage.Save
'=======================================================================
MsgBox "IN PROGRESS"
'=======================================================================
strname = repertoire & "Email " & Sujet
objCurrentMessage.SaveAs strname & ".htm", OlSaveAsType.olHTML
objCurrentMessage.HTMLBody = OLDhtml
objCurrentMessage.Save

On Error Resume Next
repertoire = ""
Sujet = ""
strEntryID = ""
End If
Set objCurrentMessage = Nothing
Set colAttach = Nothing
Set ExpShell = Nothing
End Sub

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
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
Set oMsg = oSession.GetMessage(strEntryID)
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
 
First of all, I'd make the MAPI.Session object global or pass it to the CDO
procedure instead of logging on and logging off each time. That can cause
memory leaks. I'd also save the CDO.Message object after changing the
attachment fields.

Second, I'd release all references to the mail item before calling the CDO
code and then pick them up again after it returns.

Based on that code you are getting the original subject as Sujet and then
setting Sujet as "mail". Did you intend to concatenate "mail" to the current
ConversationIndex?

If I were doing this code I'd probably try to rewrite it to do only 1 call
to the CDO procedure if possible.

Instead of the MsgBox see if putting in a DoEvents helps in addition to my
other suggestions.




Oliv' said:
*Ken Slovak - said:
No, I don't download and run code from the Web, sorry.

Show the relevant piece of your code in a post here and let us see
what you are doing and also provide the message the dialog is showing
so we know what's going on.
Click to expand...

Hello Ken
If i comment MsgBox "IN PROGRESS" the export is bad why ?
Thank you
This is my code :

Sub SaveAsHtmlFileWithEmbedded()
Dim objCurrentMessage As Outlook.MailItem
Dim colAttach As Outlook.Attachments
Dim Sujet
Dim OLDhtml
Dim strEntryID
Set objCurrentMessage = ActiveInspector.CurrentItem
Set colAttach = objCurrentMessage.Attachments
If objCurrentMessage.BodyFormat = olFormatHTML Then
Sujet = objCurrentMessage.ConversationIndex
Sujet = "mail"
'on crée le repertoire où mettre les fichiers joints
repertoire = "c:\temp\Email\" & Sujet & "\"

OLDhtml = objCurrentMessage.HTMLBody

strEntryID = objCurrentMessage.EntryID
Dim i, toto
For i = 1 To colAttach.Count
toto = Attachtype(strEntryID, colAttach(i).Index)
objCurrentMessage.HTMLBody = Replace(objCurrentMessage.HTMLBody, _
"cid:" & toto, "embedded\" & colAttach(i).FileName)
colAttach(i).SaveAsFile repertoire & "embedded\" & _
colAttach(i).FileName
Next i


objCurrentMessage.Save
'=======================================================================
MsgBox "IN PROGRESS"
'=======================================================================
strname = repertoire & "Email " & Sujet
objCurrentMessage.SaveAs strname & ".htm", OlSaveAsType.olHTML
objCurrentMessage.HTMLBody = OLDhtml
objCurrentMessage.Save

On Error Resume Next
repertoire = ""
Sujet = ""
strEntryID = ""
End If
Set objCurrentMessage = Nothing
Set colAttach = Nothing
Set ExpShell = Nothing
End Sub

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
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
Set oMsg = oSession.GetMessage(strEntryID)
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

Oliv' said:
*Ken Slovak - [MVP - Outlook] <[email protected]> que je salue a
écrit *:
And is the MSG file and the original item both updated? I don't
understand the problem or why you would need a MsgBox dialog.


Precisely, I don't want this MsgBox dialog but if it is not there
export is not good.
link to my code as .bas file http://cjoint.com/?ccmnqyrzFU if you
want to test it
you need "c:\temp" directory
Sorry my english is very bad
Oliv'
Click to expand...
Click to expand...
Click to expand...
 
*Ken Slovak - said:
First of all, I'd make the MAPI.Session object global or pass it to
the CDO procedure instead of logging on and logging off each time.
That can cause memory leaks. I'd also save the CDO.Message object
after changing the attachment fields.

Second, I'd release all references to the mail item before calling
the CDO code and then pick them up again after it returns.

Based on that code you are getting the original subject as Sujet and
then setting Sujet as "mail". Did you intend to concatenate "mail" to
the current ConversationIndex?
Click to expand...
If I were doing this code I'd probably try to rewrite it to do only 1
call to the CDO procedure if possible.

Instead of the MsgBox see if putting in a DoEvents helps in addition
to my other suggestions.
Click to expand...

Hello Ken,
Yes i concatenate several fields
It's ok with DoEvents, and i will try to Improve my code with your
suggestions
Thank you .

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


Oliv' said:
*Ken Slovak - said:
No, I don't download and run code from the Web, sorry.

Show the relevant piece of your code in a post here and let us see
what you are doing and also provide the message the dialog is
showing so we know what's going on.
Click to expand...

Hello Ken
If i comment MsgBox "IN PROGRESS" the export is bad why ?
Thank you
This is my code :

Sub SaveAsHtmlFileWithEmbedded()
Dim objCurrentMessage As Outlook.MailItem
Dim colAttach As Outlook.Attachments
Dim Sujet
Dim OLDhtml
Dim strEntryID
Set objCurrentMessage = ActiveInspector.CurrentItem
Set colAttach = objCurrentMessage.Attachments
If objCurrentMessage.BodyFormat = olFormatHTML Then
Sujet = objCurrentMessage.ConversationIndex
Sujet = "mail"
'on crée le repertoire où mettre les fichiers joints
repertoire = "c:\temp\Email\" & Sujet & "\"

OLDhtml = objCurrentMessage.HTMLBody

strEntryID = objCurrentMessage.EntryID
Dim i, toto
For i = 1 To colAttach.Count
toto = Attachtype(strEntryID, colAttach(i).Index)
objCurrentMessage.HTMLBody = Replace(objCurrentMessage.HTMLBody, _
"cid:" & toto, "embedded\" & colAttach(i).FileName)
colAttach(i).SaveAsFile repertoire & "embedded\" & _
colAttach(i).FileName
Next i


objCurrentMessage.Save
'=======================================================================
MsgBox "IN PROGRESS"
'=======================================================================
strname = repertoire & "Email " & Sujet
objCurrentMessage.SaveAs strname & ".htm", OlSaveAsType.olHTML
objCurrentMessage.HTMLBody = OLDhtml
objCurrentMessage.Save

On Error Resume Next
repertoire = ""
Sujet = ""
strEntryID = ""
End If
Set objCurrentMessage = Nothing
Set colAttach = Nothing
Set ExpShell = Nothing
End Sub

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
On Error Resume Next
Set oSession = CreateObject("MAPI.Session")
oSession.Logon "", "", False, False
Set oMsg = oSession.GetMessage(strEntryID)
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

*Ken Slovak - [MVP - Outlook] <[email protected]> que je salue a
écrit *:
And is the MSG file and the original item both updated? I don't
understand the problem or why you would need a MsgBox dialog.


Precisely, I don't want this MsgBox dialog but if it is not there
export is not good.
link to my code as .bas file http://cjoint.com/?ccmnqyrzFU if you
want to test it
you need "c:\temp" directory
Sorry my english is very bad
Oliv'
Click to expand...
Click to expand...
Click to expand...
 
Back
Top