terrynoya · December 28, 2012 06:24
diff --git a/CDOSysEmbeddedImages.vbs b/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("[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
	'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