Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
VBScript/VBA function for sending HTML email with embedded images
'This function is intended to make it a little easier to add images to emails when sending them
' through CDOSYS (CDO.Message). If all the following are true, this may help:
' - You want to send an HTML email, with one or more images in the email body
' - You want the images to be in the email itself, so that they display without any security or privacy warnings
' - You don't want the images to show up explicitly as "Attachments" in email clients like Microsoft Outlook
' - You don't want to use the images to "track" who has read your emails (that requirement would be incompatible with the rest)
' - You are using VBScript (ASP, WSH) or Office Visual Basic for Applications (VBA), or Visual Basic 6 (VB6)
' This code is loosely based on a collection of prior resources/examples online:
' - VBS/VBA versions using "AddRelatedBodyPart":
' -
' -
' -
' - C# versions using "AlternateView" and "LinkedResources":
' -
' -
' This function will locate any special "<EMBEDDEDIMAGE:filename>" tags in the message HTML, and do the
' necessary file embedding (replacing the special tag with the final reference to the hidden attachment)
' The function "PrepareMessageWithEmbeddedImages" below is the useful one; the "SendMessageBySMTP"
' function is just generic code that is already plastered all over the internet.
' To run successfully from VB6 or VBA, this code requires the following 2 references to be added:
' - Microsoft CDO for Windows 2000 Library
' - Microsoft VBScript Regular Expressions 5.5
' There is no error-handling specified in these functions right now. Most types of errors that could be
' raised ("file cannot be found", "smtp connection failed", etc) are pretty obvious, so adding a lot of
' boilerplate error-handling code would be counter-productive for a simple example.
' (Some online postings suggest you need a 3rd-party component like AspEmail to do this, but that's
' definitely untrue. What AspEmail does do is make it slightly easier than CDO, eg:
' Example (to run from VBA or VB6 or VBS)
' - replace the email addresses and password
' - also replace the SMTP server if not using Gmail
' - also make sure that the images (eg "C:\test.jpeg") exist on your computer OR change the HTML to refer to images that you do have
' Dim MessageText, MessageObject
' MessageText = "<html><body>Some Image: <img src=""<EMBEDDEDIMAGE:C:\test.jpeg>"" /><p>Another Image: <img src=""<EMBEDDEDIMAGE:C:\test2.jpeg>"" /></body></html>"
' Set MessageObject = PrepareMessageWithEmbeddedImages("", "", "Some Message", MessageText)
' SendMessageBySMTP MessageObject, "", 465, "", "testpassword", True
Option Explicit
Function PrepareMessageWithEmbeddedImages(ByVal FromAddress, ByVal ToAddress, ByVal Subject, ByVal HtmlContent)
Dim Message, Attachment, Expression, Matches, FilenameMatch, i
Set Expression = CreateObject("VBScript.RegExp")
Expression.Pattern = "\<EMBEDDEDIMAGE\:(.+?)\>"
Expression.IgnoreCase = True
Expression.Global = False 'one match at a time
Set Message = CreateObject("CDO.Message")
Message.From = FromAddress
Message.To = ToAddress
Message.Subject = Subject
'Find matches in email body, incrementally increasing the auto-assigned attachment identifiers
i = 1
While Expression.Test(HtmlContent)
FilenameMatch = Expression.Execute(HtmlContent).Item(0).SubMatches(0)
Set Attachment = Message.AddAttachment(FilenameMatch)
Attachment.Fields.Item("urn:schemas:mailheader:Content-ID") = "<attachedimage" & i & ">" ' set an ID we can refer to in HTML
Attachment.Fields.Item("urn:schemas:mailheader:Content-Disposition") = "inline" ' "hide" the attachment
HtmlContent = Expression.Replace(HtmlContent, "cid:attachedimage" & i) ' update the HTML to refer to the actual attachment
i = i + 1
Message.HTMLBody = HtmlContent
Set PrepareMessageWithEmbeddedImages = Message
End Function
Function SendMessageBySMTP(ByRef Message, ByVal SmtpServer, ByVal SmtpPort, ByVal SmtpUsername, ByVal SmtpPassword, ByVal UseSSL)
Dim Configuration
Set Configuration = CreateObject("CDO.Configuration")
Configuration.Load -1 ' CDO Source Defaults
Configuration.Fields.Item("") = 2
Configuration.Fields.Item("") = SmtpServer
Configuration.Fields.Item("") = SmtpPort
If SmtpUsername <> "" Then
Configuration.Fields.Item("") = 1
Configuration.Fields.Item("") = SmtpUsername
Configuration.Fields.Item("") = SmtpPassword
End If
Configuration.Fields.Item("") = UseSSL
Set Message.Configuration = Configuration
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment