Embed Pictures in an Email

It is possible to embed a picture in an HTML formatted email so that it is displayed in the text area. if you do that by using Outlook's object model, not the pictures are sent with the email but the file path only. That is if the file path isn't valid on the receiver's computer (which it most likely is not), then the receiver cannot see the picture but only the red cross.

By using the Redemption you can really embed a picture so that it's sent with the email. This works also with an audio file, which will be played when the user opens the email in HTML format. Even animated GIFs are possible (at least with Outlook 2003).

I got the idea for the sample from Dmitry himself.

Additionally needed functions: Create a Redemption SafeMailItem

  How to add macros to Outlook

Private Type EmbeddedObj
  Key As String
  Type As String
  Source As String
  Tag As String
  Description As String
End Type

Private m_SafeMail As Object
Private m_Buffer As String
Private m_StartPos As Long
Private m_EndPos As Long

Public Sub AufrufBeispiel()
  Dim ImageMail As MailItem
  Dim AudioMail As MailItem
  Dim imgf$, audf$

  imgf = "d://laugh.gif"
  audf = "d://qopen.wav"

  Set ImageMail = Application.CreateItem(olMailItem)
  ImageMail.BodyFormat = olFormatHTML
  Set AudioMail = ImageMail.Copy

  ImageMail.Subject = "test image"
  ImageMail.HTMLBody = "Image of the day: @0  - text continues here"
  ImageMail.Display
  AddEmbeddedAttachment ImageMail, imgf, "@0", "(Image of the day)"

  AudioMail.Subject = "test audio"
  AudioMail.Display
  AddEmbeddedAttachment AudioMail, audf
End Sub

'  -> File: Full name of the file you want to embed.
'           suported types:
'           - Image: "gif", "jpg", "jpeg", "bmp", "png"
'           - Audio: "wav", "wma"
'  -> [PositionID]: For images you can determine the position by a placeholder
'  -> [Description]: alt text for images
Public Sub AddEmbeddedAttachment(Mail As Outlook.MailItem, _
  File As String, _
  Optional PositionID As String, _
  Optional Description As String _
)
  On Error GoTo AUSGANG
  Dim Obj As EmbeddedObj

  Mail.Save
  Set m_SafeMail = CreateSafeItem(Mail)
  m_Buffer = m_SafeMail.HTMLBody

  Obj.Source = File
  Obj.Description = Description
  Obj.Type = GetContentType(GetExtension(File))
  Obj.Key = GetNewID
  FindPosition PositionID

  Select Case left$(Obj.Type, 1)
  Case "i"
    ' Image
    CreateImageTag Obj
  Case "a"
    ' Audio
    CreateAudioTag Obj
  Case Else
    ' Nicht unterstützt
    GoTo AUSGANG
  End Select

  AddAttachment Obj
  InsertTagIntoMail Obj.Tag

AUSGANG:
  ReleaseSafeItem m_SafeMail
End Sub

Private Function GetContentType(Extension As String) As String
  Select Case Extension
  Case "wav", "wma"
    GetContentType = "audio/" & Extension
  Case "avi"
    GetContentType = "video/" & Extension
  Case "gif", "jpg", "jpeg", "bmp", "png"
    GetContentType = "image/" & Extension
  End Select
End Function

Private Function GetExtension(File As String) As String
  GetExtension = Mid$(File, InStrRev(File, ".") + 1)
End Function

Private Function GetNewID() As String
  Randomize
  GetNewID = CStr(Int((99999 - 10000 + 1) * Rnd + 10000))
End Function

Private Sub FindPosition(Find As String)
  Dim posAnf As Long
  Dim posEnd As Long

  If Len(Find) Then
    posAnf = InStr(m_Buffer, Find)
    If posAnf Then
      posEnd = posAnf + Len(Find) - 1
    End If
  End If

  If posAnf = 0 Then
    posAnf = InStr(1, m_Buffer, "", vbTextCompare)
    If posAnf = 0 Then
      posAnf = Len(m_Buffer) + 1
    End If
    posEnd = posAnf - 1
  End If

  m_StartPos = posAnf
  m_EndPos = posEnd
End Sub

Private Sub CreateImageTag(Obj As EmbeddedObj)
  Obj.Tag = "<" & "img src='cid:" & Obj.Key
  Obj.Tag = Obj.Tag & "' align=baseline border=0 hspace=0"

  If Len(Obj.Description) Then
    Obj.Tag = Obj.Tag & " alt='" & Obj.Description & "'>"
  Else
    Obj.Tag = Obj.Tag & ">"
  End If
End Sub

Private Sub CreateAudioTag(Obj As EmbeddedObj)
  Obj.Tag = "<" & bgsound src='cid:" & Obj.Key & "'>"
End Sub

Private Sub AddAttachment(Obj As EmbeddedObj)
  Dim Attachment As Object 'Redemption.Attachmentment
  Dim PR_HIDE_ATTACH As Long
  Const PT_BOOLEAN As Long = 11

  PR_HIDE_ATTACH = _
    m_SafeMail.GetIDsFromNames("{00062008-0000-0000-C000-000000000046}", _
    &H8514) Or PT_BOOLEAN
  m_SafeMail.Fields(PR_HIDE_ATTACH) = True
  Set Attachment = m_SafeMail.Attachments.Add(Obj.Source)
  Attachment.Fields(&H370E001E) = Obj.Type
  Attachment.Fields(&H3712001E) = Obj.Key
  Set Attachment = Nothing
End Sub

Private Sub InsertTagIntoMail(Tag As String)
  m_Buffer = left$(m_Buffer, m_StartPos - 1) _
              & Tag & _
              right$(m_Buffer, Len(m_Buffer) - m_EndPos)
  m_SafeMail.HTMLBody = m_Buffer
End Sub