Bilder in Emails einbetten

Sie können Bilder in HTML E-Mails einbetten, so dass diese im Text gesehen werden. Wenn Sie das per Code über das Outlook Objektmodell machen, dann werden die Bilddateien aber nicht mitgesendet, sondern nur die Dateipfade. Das bedeutet, wenn auf Empfängerseite die Datei nicht unter dem gleichen Pfad vorhanden ist, dann wird nur ein Platzhalter (ein rotes Kreuz) angezeigt.

Dieses Beispiel demonstriert, wie Sie mithilfe der Redemption Anlagen einbetten können, so dass die Dateien selbst mitgesendet werden. Das funktioniert aber nicht nur mit Bildern, sondern auch mit einer Audiodatei. Diese wird abgespielt, wenn der Empfänger die Mail im HTML-Format öffnet. Als Bilder werden auch animierte GIFs unterstützt (das galt zumindest bis Outlook 2003).

(Die Vorlage für das Beispiel stammt von Dmitry Streblchenko)

Weitere benötigte Funktionen: Redemption SafeMailItem erzeugen

  So fügen Sie Makros in Outlook ein

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 des Tages: @0  - und weiter im Text"
  ImageMail.Display
  AddEmbeddedAttachment ImageMail, imgf, "@0", "(Image des Tages)"

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

'----------------------------------------------------------------------------
' Procedure:AddEmbeddedAttachment
' DateTime :21.05.2006 10:35
' Author   :Michael Bauer
' Purpose  :Fügt einer HTML E-Mail eine Anlage als eingebettetes
'   Objekt hinzu.
'  -> Mail: Das Outlook MailItem
'  -> File: Vollständiger Dateipfad auf die einzufügende Anlage.
'           Unterstützt werden:
'           - Image: "gif", "jpg", "jpeg", "bmp", "png"
'           - Audio: "wav", "wma"
'  -> [PositionID]: Für Images kann mit Hilfe eines eindeutigen
'           Platzhalters die Einfügeposition bestimmt werden.
'  -> [Description]: Für Images kann zusätzlich eine Beschreibung
'           angegeben werden. Dieser Text erscheint, wenn der
'           Empfänger die Mail als einfachen Text anzeigt oder in der
'           HTML-Mail mit der Maus über das Bild fährt.
'----------------------------------------------------------------------------
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.Attachment
  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