Skip to content

@TaoK /CDOSysEmbeddedImages.vbs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
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":
' - http://blog.dastrup.com/?p=60
' - http://support.jodohost.com/threads/tut-how-to-add-embedded-images-in-cdo-mail.7692/
' - http://www.webdeveloper.com/forum/showthread.php?t=173569
' - C# versions using "AlternateView" and "LinkedResources":
' - http://log.itto.be/?p=486
' - http://stackoverflow.com/questions/2699272/send-automated-email-through-windows-service-that-has-an-embedded-image-using-c
'
' 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:
' http://www.aspemail.com/manual_04.html)
'
'
' 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("test@gmail.com", "test@gmail.com", "Some Message", MessageText)
' SendMessageBySMTP MessageObject, "smtp.gmail.com", 465, "test@gmail.com", "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
Attachment.Fields.Update
HtmlContent = Expression.Replace(HtmlContent, "cid:attachedimage" & i) ' update the HTML to refer to the actual attachment
i = i + 1
Wend
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("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SmtpServer
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SmtpPort
If SmtpUsername <> "" Then
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SmtpUsername
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SmtpPassword
End If
Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = UseSSL
Configuration.Fields.Update
Set Message.Configuration = Configuration
Message.Send
End Function
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.