Skip to content

Instantly share code, notes, and snippets.

@TaoK

TaoK/CDOSysEmbeddedImages.vbs

Created August 30, 2012 09:53
Download ZIP

Revisions

  1. TaoK revised this gist Aug 30, 2012. 1 changed file with 2 additions and 2 deletions.
    4 changes: 2 additions & 2 deletions CDOSysEmbeddedImages.vbs
    View file
    Original file line number Diff line number Diff line change
    @@ -39,7 +39,7 @@
    ' - 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>"
    ' 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
    '
    @@ -91,4 +91,4 @@ Function SendMessageBySMTP(ByRef Message, ByVal SmtpServer, ByVal SmtpPort, ByVa
    Configuration.Fields.Update
    Set Message.Configuration = Configuration
    Message.Send
    End Function
    End Function
  2. TaoK created this gist Aug 30, 2012.
    94 changes: 94 additions & 0 deletions CDOSysEmbeddedImages.vbs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,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