Email active sheet or embedded objects not as an attachment

Tbone · Sep 16, 2003

I have a worksheet that contains embedded objects. Users are making selections with dropdowns and check boxes. How do I copy this worksheet, actually just the embedded objects, into the body of the email. The embedded object is grouped. I can send it as an attachment, but I rather have the results pasted into the body of the email. I can do this physical, but of course I need help doing this through VBA. I'm using Excel 2000 & Outlook 2000.

Thanks

Tbone

Ivan F Moala · Sep 16, 2003

NOT an easy task to do.....but try this;

Assumes you have a grouped object;

<pre>Option Explicit

'To create an HTML message that included an embedded image -- that, instead,
'all "" <img> "" tags had to use full URLs to public web addresses.
'The impossible has become possible, though, through the efforts of Outlook MVP Neo,
'who devised a method that uses undocumented MAPI properties and CDO.

'CDO = Microsoft® Collaboration Data Objects
'CDO does not represent a new messaging model, but rather an additional scripting interface
'to the Messaging Application Programming Interface (MAPI) model.

'for more info see;
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/cdo/html/_olemsg_overview_of_cdo.asp

'For versions see;
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dncdsys/html/cdo_roadmap.asp

'In VBA or Visual Basic you will need to add a reference to the CDO 1.21 library to use this procedure.
'For client applications, you should install Outlook in order to install CDO.
'In Outlook 2000 and Outlook 2002, CDO is included, but you must explicitly select
'it during setup.

'Microsoft CDO 1.21 Library
'MAPI
'GUID = {3FA7DEA7-6438-101B-ACC1-00AA00423326}
'Path C:\PROGRA~1\COMMON~1\System\Mapi\1033\NT\CDO.DLL
'GUID Ref .AddFromGuid "{3FA7DEA7-6438-101B-ACC1-00AA00423326}",1,21
'.Item("MAPI")

Sub InsertObjectInEmail_V1()
'// Ivan F Moala 17th March 2003
'// Amendment
'// Ivan F Moala 30th June 2003
'// Ivan F Moala 17th Sept 2003:- Set as Grouped Object
'// Thanks to Outlook MVP Neo
'// Original used "<img src=" image full address
'// So the image had to have a url web address to
'// be viewed properly
'// Testing under Xl2000 / WinXP

'// Dimension variables, lets use Latebinding
Dim oOutlookApp As Object
Dim oOutlookMessage As Object
Dim oFSObj As Object
Dim strHTMLBody As String
Dim strTempFilePath As String
Dim oOutlookAppAttach As Object
Dim oOutlook_Att As Object
Dim strEntryID As String
Dim oSession As Object

'// Use Early binding = Reference CDO
Dim oMsg As MAPI.Message
Dim oAttachs As MAPI.Attachments
Dim oAttach As MAPI.Attachment
Dim colFields As MAPI.Fields
Dim oField As MAPI.Field
Dim ID As Object
Dim objPict As Shape
Dim MyChart As Chart
Dim GrpCtrl As Shape
Dim blnPict As Boolean

'// You need to run this in the Sheet that has the Image!
For Each GrpCtrl In ActiveSheet.Shapes
'//6 = grouped controls
If GrpCtrl.Type = 6 Then
If MsgBox("Email this Grouped control:= " & GrpCtrl.Name & vbCr & _
"Use this ? ", vbYesNo) = vbYes Then
Set objPict = ActiveSheet.Shapes(GrpCtrl.Name)
blnPict = True
Exit For
End If
End If
Next

'// Make sure that an Image is set
If Not blnPict Then MsgBox "No Picture selected!": Exit Sub

'//
'Get the temp folder path
Set oFSObj = CreateObject("Scripting.FilesystemObject")

strTempFilePath = oFSObj.GetSpecialFolder(2)
strTempFilePath = strTempFilePath & "\MyImg.gif"

With objPict
.CopyPicture 1, 2
Set MyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width + 8, .Height + 8).Chart
End With

'// Export the chart. We'll use it later
With MyChart
.Paste
.Export strTempFilePath
.Parent.Delete
End With

'//
'Create an instance of Outlook (or use existing instance if it already exists
Set oOutlookApp = CreateObject("Outlook.Application")

'Create a mail item
Set oOutlookMessage = oOutlookApp.CreateItem(0)
Set oOutlookAppAttach = oOutlookMessage.Attachments
' add graphic as attachment to Outlook message
' change path to graphic as needed
Set oOutlook_Att = oOutlookAppAttach.Add(strTempFilePath)

'// Lets save the msg, this is so that the EntryID property
'// is set.
oOutlookMessage.Close olSave

'// Lets get the unique entry ID of the object.
'// EntryID property corresponds to the MAPI property PR_ENTRYID.
'// MAPI systems assign a permanent, unique ID string when an object
'// is created that does not change from one MAPI session to another.
'// Also, the EntryID changes when an item is moved into another folder.
strEntryID = oOutlookMessage.EntryID

Set oOutlookMessage = Nothing
' *** POSITION CRITICAL *** you must dereference the
' attachment objects before changing their properties
' via CDO
Set oOutlookAppAttach = Nothing

'// 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(1)
Set colFields = oAttach.Fields

'// Set oField = oFieldsColl.Add (name, Class [, value] [, PropsetID] )
Set oField = colFields.Add(CdoPR_ATTACH_MIME_TAG, "image/gif")
Set oField = colFields.Add(&H3712001E, "MyIdent")

oMsg.Fields.Add "{0820060000000000C000000000000046}0x8514", 11, True
oMsg.Update

'// Here put any HTML you want - this is just an example
strHTMLBody = "This is the Image you were looking for.
"
strHTMLBody = strHTMLBody & "Get back to me ASAP
"
strHTMLBody = strHTMLBody & "Looking forward to your reply.

"
strHTMLBody = strHTMLBody & "Ivan F Moala

<hr>"

' get the Outlook MailItem again
Set oOutlookMessage = oOutlookApp.GetNamespace("MAPI").GetItemFromID(strEntryID)

' add HTML content -- the <IMG> tag
With oOutlookMessage
.HTMLBody = strHTMLBody & "<IMG align=baseline border=0 hspace=0 SRC=cid:MyIdent>"
.Close (olSave)
.Display
End With

'// cleanup
Set oFSObj = Nothing
Set oField = Nothing
Set colFields = Nothing
Set oMsg = Nothing
Set oAttachs = Nothing
Set oAttach = Nothing
Set colFields = Nothing

oSession.Logoff

Set oSession = Nothing
Set oOutlookApp = Nothing
Set oOutlookMessage = Nothing

Kill strTempFilePath

End Sub

</pre>

Tbone · Sep 17, 2003

Re: Email active sheet or embedded objects not as an attachm

WOW! I didn't think it would take all that. Just an attachment is easy, but this is a challenge. Thanks for the code Ivan, I will try this out, and post another message to let you and everyone else know if it worked out for me.

Tbone · Sep 18, 2003

Re: Email active sheet or embedded objects not as an attachm

I have copied the code and with no modification so far, I am unable to compile. error occurs at olSave....any idea why this happens. I have added the reference CDO 1.21

TBone

Juan Pablo González · Sep 18, 2003

Re: Email active sheet or embedded objects not as an attachm

Replace any instance of

olSave

with

0

That, is, zero.

Juan Pablo González · Sep 18, 2003

Re: Email active sheet or embedded objects not as an attachm

Let's see if this works. Very cool code Ivan !

Option Explicit

'To create an HTML message that included an embedded image -- that, instead,
'all "<IMG>" tags had to use full URLs to public web addresses.
'The impossible has become possible, though, through the efforts of Outlook MVP Neo,
'who devised a method that uses undocumented MAPI properties and CDO.

'CDO = Microsoft® Collaboration Data Objects
'CDO does not represent a new messaging model, but rather an additional scripting interface
'to the Messaging Application Programming Interface (MAPI) model.

'for more info see;
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/cdo/html/_olemsg_overview_of_cdo.asp

'For versions see;
'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dncdsys/html/cdo_roadmap.asp

'In VBA or Visual Basic you will need to add a reference to the CDO 1.21 library to use this procedure.
'For client applications, you should install Outlook in order to install CDO.
'In Outlook 2000 and Outlook 2002, CDO is included, but you must explicitly select
'it during setup.

'Microsoft CDO 1.21 Library
'MAPI
'GUID = {3FA7DEA7-6438-101B-ACC1-00AA00423326}
'Path C:\PROGRA~1\COMMON~1\System\Mapi\1033\NT\CDO.DLL
'GUID Ref .AddFromGuid "{3FA7DEA7-6438-101B-ACC1-00AA00423326}",1,21
'.Item("MAPI")

Sub InsertObjectInEmail_V1()
 '// Ivan F Moala 17th March 2003
 '// Amendment
 '// Ivan F Moala 30th June 2003
 '// Ivan F Moala 17th Sept 2003:- Set as Grouped Object
 '// Thanks to Outlook MVP Neo
 '// Original used "<IMG>"
 '// So the image had to have a url web address to
 '// be viewed properly
 '// Testing under Xl2000 / WinXP

 '// Dimension variables, lets use Latebinding
 Dim oOutlookApp As Object
 Dim oOutlookMessage As Object
 Dim oFSObj As Object
 Dim strHTMLBody As String
 Dim strTempFilePath As String
 Dim oOutlookAppAttach As Object
 Dim oOutlook_Att As Object
 Dim strEntryID As String
 Dim oSession As Object

 '// Use Early binding = Reference CDO
 Dim oMsg As MAPI.Message
 Dim oAttachs As MAPI.Attachments
 Dim oAttach As MAPI.Attachment
 Dim colFields As MAPI.Fields
 Dim oField As MAPI.Field
 Dim ID As Object
 Dim objPict As Shape
 Dim MyChart As Chart
 Dim GrpCtrl As Shape
 Dim blnPict As Boolean

 '// You need to run this in the Sheet that has the Image!
 For Each GrpCtrl In ActiveSheet.Shapes
 '//6 = grouped controls
 If GrpCtrl.Type = 6 Then
 If MsgBox("Email this Grouped control:= " & GrpCtrl.Name & vbCr & _
 "Use this ? ", vbYesNo) = vbYes Then
 Set objPict = ActiveSheet.Shapes(GrpCtrl.Name)
 blnPict = True
 Exit For
 End If
 End If
 Next

 '// Make sure that an Image is set
 If Not blnPict Then MsgBox "No Picture selected!": Exit Sub

 '//
 'Get the temp folder path
 Set oFSObj = CreateObject("Scripting.FilesystemObject")

 strTempFilePath = oFSObj.GetSpecialFolder(2)
 strTempFilePath = strTempFilePath & "\MyImg.gif"

 With objPict
 .CopyPicture 1, 2
 Set MyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width + 8, .Height + 8).Chart
 End With

 '// Export the chart. We'll use it later
 With MyChart
 .Paste
 .Export strTempFilePath
 .Parent.Delete
 End With

 '//
 'Create an instance of Outlook (or use existing instance if it already exists
 Set oOutlookApp = CreateObject("Outlook.Application")

 'Create a mail item
 Set oOutlookMessage = oOutlookApp.CreateItem(0)
 Set oOutlookAppAttach = oOutlookMessage.Attachments
 ' add graphic as attachment to Outlook message
 ' change path to graphic as needed
 Set oOutlook_Att = oOutlookAppAttach.Add(strTempFilePath)

 '// Lets save the msg, this is so that the EntryID property
 '// is set.
 oOutlookMessage.Close 0

 '// Lets get the unique entry ID of the object.
 '// EntryID property corresponds to the MAPI property PR_ENTRYID.
 '// MAPI systems assign a permanent, unique ID string when an object
 '// is created that does not change from one MAPI session to another.
 '// Also, the EntryID changes when an item is moved into another folder.
 strEntryID = oOutlookMessage.EntryID

 Set oOutlookMessage = Nothing
 ' *** POSITION CRITICAL *** you must dereference the
 ' attachment objects before changing their properties
 ' via CDO
 Set oOutlookAppAttach = Nothing

 '// 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(1)
 Set colFields = oAttach.Fields

 '// Set oField = oFieldsColl.Add (name, Class [, value] [, PropsetID] )
 Set oField = colFields.Add(CdoPR_ATTACH_MIME_TAG, "image/gif")
 Set oField = colFields.Add(&H3712001E, "MyIdent")

 oMsg.Fields.Add "{0820060000000000C000000000000046}0x8514", 11, True
 oMsg.Update

 '// Here put any HTML you want - this is just an example
 strHTMLBody = "This is the Image you were looking for.
"
 strHTMLBody = strHTMLBody & "Get back to me ASAP
"
 strHTMLBody = strHTMLBody & "Looking forward to your reply.

"
 strHTMLBody = strHTMLBody & "Ivan F Moala"

 ' get the Outlook MailItem again
 Set oOutlookMessage = oOutlookApp.GetNamespace("MAPI").GetItemFromID(strEntryID)

 ' add HTML content -- the <IMG> Tag
 With oOutlookMessage
 .HTMLBody = strHTMLBody & "<IMG align=baseline border=0 hspace=0 SRC=cid:MyIdent>"
 .Close 0
 .Display
 End With

 '// cleanup
 Set oFSObj = Nothing
 Set oField = Nothing
 Set colFields = Nothing
 Set oMsg = Nothing
 Set oAttachs = Nothing
 Set oAttach = Nothing
 Set colFields = Nothing

 oSession.Logoff

 Set oSession = Nothing
 Set oOutlookApp = Nothing
 Set oOutlookMessage = Nothing

 Kill strTempFilePath

End Sub

Tbone · Sep 18, 2003

Re: Email active sheet or embedded objects not as an attachm

Thanks Juan. It now complies, but the code still doesn't attach the image into the email as an image. It attaches it as an attachment. I don't know where it's going wrong. I tried to debug it, but can't figure out why it's not an image of the group.

Tbone

Juan Pablo González · Sep 18, 2003

Re: Email active sheet or embedded objects not as an attachm

Mhm, it worked ok using Outlook 2002. Don't have (Can't have !) Outlook 2000 so, don't know if that may be it...

Ivan F Moala · Jun 14, 2004

Re: Email active sheet or embedded objects not as an attachm

Tbone said:
Thanks Juan. It now complies, but the code still doesn't attach the image into the email as an image. It attaches it as an attachment. I don't know where it's going wrong. I tried to debug it, but can't figure out why it's not an image of the group.

Tbone

Try this version

http://www.xcelfiles.com/EmailImg.html

Email active sheet or embedded objects not as an attachment

Tbone

New Member

Excel Facts

Ivan F Moala

MrExcel MVP

Tbone

New Member

Tbone

New Member

Juan Pablo González

MrExcel MVP

Juan Pablo González

MrExcel MVP

Tbone

New Member

Juan Pablo González

MrExcel MVP

Ivan F Moala

MrExcel MVP

Similar threads

Forum statistics

Share this page

Email active sheet or embedded objects not as an attachment

New Member

Excel Facts

MrExcel MVP

New Member

New Member

MrExcel MVP

MrExcel MVP

New Member

MrExcel MVP

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock