TaoK/CDOSysEmbeddedImages.vbs

## CDOSysEmbeddedImages.vbs
'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
	'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