public
Last active

VBScript/VBA function for sending HTML email with embedded images

  • Download Gist
CDOSysEmbeddedImages.vbs
Visual Basic
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94
'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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.