These images are usually just animated gifs. All you really need is a cache of thes on your drive and the below code (which I have amended from my site) to do this from within Excel.....
This code inserts an image as a signature OR background
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")
'//
Const strHTMLCredit1 As String = _
"<br><br><b><i><FONT SIZE=2> Automation - Emailer by Ivan F Moala 2003"
Const strHTMLCredit2 As String = _
"<br><A HREF='http://www.xcelfiles.com'>Visit my Site</A></i></b><br><br>"
'//
Const CdoPR_ATTACH_MIME_TAG As Long = &H370E001E '&H3712001E
Const olSave = 0
Sub InsertPictureInEmail_V2()
'/////////////////////////////////////////
'// Ivan F Moala 17th March 2003 //
'// Amendment //
'// Ivan F Moala 30th June 2003 //
'// Credit to Outlook MVP Neo //
'// Testing under Xl2000 / WinXP //
'// Testing under Xl2003 / WinXP //
'/////////////////////////////////////////
'// Dimension variables using Latebinding
Dim objOutlookApp As Object
Dim objOutlookMessage As Object
Dim strHTMLBody As String
Dim objOutlookAppAttach As Object
Dim objOutlook_Att As Object
Dim strEntryID As String
Dim objSession As Object
Dim vFileImage As Variant
'// To counter the change in Dir due to MAPI
Dim strIniFolder As String
'
Dim blnSignature As Boolean
'// Use late binding 'Reference CDO
Dim objMsg As Object 'MAPI.Message
Dim objAttachs As Object 'MAPI.Attachments
Dim objAttach As Object 'MAPI.Attachment
Dim colFields As Object 'MAPI.Fields
Dim oField As Object 'MAPI.Field
'// Sheet
'Dim objPict As Object
'Dim MyChart As Chart
'Dim rgImgSend As Range
'//
strIniFolder = CurDir
LoadImg:
vFileImage = Application.GetOpenFilename("Image Files (*.gif),*.gif")
If TypeName(vFileImage) = "Boolean" Then Exit Sub
If MsgBox("Insert Signature (Yes) OR Background? (No)", vbYesNo, "aaa") = vbYes Then
blnSignature = True
Else
blnSignature = False
End If
'// Create an instance of Outlook (or use existing instance if it already exists)
On Error Resume Next
Set objOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set objOutlookApp = CreateObject("Outlook.Application")
'// We need the Application Open in order to NOT show as attachment
Shell objOutlookApp, vbMaximizedFocus
End If
On Error GoTo 0
'// Create a mail item
Set objOutlookMessage = objOutlookApp.CreateItem(0)
Set objOutlookAppAttach = objOutlookMessage.Attachments
'// add graphic as attachment to Outlook message
'// change path to graphic as needed
Set objOutlook_Att = objOutlookAppAttach.Add(vFileImage)
'// Lets save the Msg, this is so that the EntryID property
'// is set.
objOutlookMessage.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 = objOutlookMessage.EntryID
Set objOutlookMessage = Nothing
' *** POSITION CRITICAL *** you must dereference the
' attachment objects before changing their properties
' via CDO
Set objOutlookAppAttach = Nothing
'// initialize CDO session
On Error Resume Next
Set objSession = CreateObject("MAPI.Session")
objSession.Logon "", "", False, False
'// get the message created earlier
Set objMsg = objSession.GetMessage(strEntryID)
'// set properties of the attached graphic that make
'// it embedded and give it an ID for use in an <IMG> tag
Set objAttachs = objMsg.Attachments
Set objAttach = objAttachs.Item(1)
Set colFields = objAttach.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")
With objMsg
.Fields.Add "{0820060000000000C000000000000046}0x8514", 11, True
.Update
End With
'// Put any HTML you want - this is just an example Signature
strHTMLBody = "<hr><br>"
strHTMLBody = strHTMLBody & "<b>Here are the details you were looking for.</b><br>"
strHTMLBody = strHTMLBody & "<b>Get back to me ASAP</b><br>"
strHTMLBody = strHTMLBody & "<b>Looking forward to your reply.</b><br><br><br>"
strHTMLBody = strHTMLBody & "<b><i>Ivan F Moala</i></b><br><br><hr>"
strHTMLBody = strHTMLBody & "<IMG align=baseline border=0 hspace=0 SRC=cid:MyIdent>" & _
strHTMLCredit1 & strHTMLCredit2
'// Get the Outlook MailItem again
Set objOutlookMessage = objOutlookApp.GetNamespace("MAPI").GetItemFromID(strEntryID)
'// add HTML content -- the <IMG> tag
With objOutlookMessage
'// Now place HTML code in Body
.HTMLBody = IIf(blnSignature, strHTMLBody, "<BODY background=cid:MyIdent></BODY>")
.Display '// Show it
End With
'// cleanup
Set oField = Nothing
Set colFields = Nothing
Set objMsg = Nothing
Set objAttachs = Nothing
Set objAttach = Nothing
Set colFields = Nothing
objSession.Logoff
Set objSession = Nothing
Set objOutlookApp = Nothing
Set objOutlookMessage = Nothing
ChDir (strIniFolder)
End Sub
Adding Smilies/Emoticons to emails
...
Reply With Quote
Originally Posted by Dreamboat
