VBScript/VBA Function For Sending HTML Email With Embedded Images

Skip to content Search Gists Search Gists All gists Back to GitHub Sign in Sign up Sign in Sign up Dismiss alert {{ message }}

Instantly share code, notes, and snippets.

TaoK/CDOSysEmbeddedImages.vbs Created August 30, 2012 09:53 Show Gist options

• Download ZIP

• Star 3 (3) You must be signed in to star a gist
• Fork 1 (1) You must be signed in to fork a gist

• Embed Select an option
  • Embed Embed this gist in your website.
  • Share Copy sharable link for this gist.
  • Clone via HTTPS Clone using the web URL.

  No results found

  Learn more about clone URLs Clone this repository at <script src="https://gist.github.com/TaoK/3525090.js"></script>
• Save TaoK/3525090 to your computer and use it in GitHub Desktop.

Code Revisions 2 Stars 3 Forks 1 Embed Select an option

• Embed Embed this gist in your website.
• Share Copy sharable link for this gist.
• Clone via HTTPS Clone using the web URL.

No results found

Learn more about clone URLs Clone this repository at <script src="https://gist.github.com/TaoK/3525090.js"></script> Save TaoK/3525090 to your computer and use it in GitHub Desktop. Download ZIP VBScript/VBA function for sending HTML email with embedded images Raw CDOSysEmbeddedImages.vbs This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode characters Show hidden characters

'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("[email protected]", "[email protected]", "Some Message", MessageText)

' SendMessageBySMTP MessageObject, "smtp.gmail.com", 465, "[email protected]", "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 You can’t perform that action at this time.