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
' Ermittelt entsprechend dem Dateitypen den korrekten
' Content-Type
  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
' Extrahiert die Dateierweiterung aus dem Dateinamen.
' Funktioniert nur, wenn ein gültiger Name übergeben
' wird.
  GetExtension = Mid$(File, InStrRev(File, ".") + 1)
End Function

Private Function GetNewID() As String
' Liefert eine zufällige Zahl zwischen 10.000 und 99.999
  Randomize
  GetNewID = CStr(Int((99999 - 10000 + 1) * Rnd + 10000))
End Function

Private Sub FindPosition(Find As String)
' Ermittelt die Start- und Endposition von Find in m_Buffer.
' Wird Find nicht gefunden, wird eine Position am Textende
' ermittelt.
  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
    ' nicht gefunden, ermittle Position am Ende des Textes
    posAnf = InStr(1, m_Buffer, "</body>", vbTextCompare)
    If posAnf = 0 Then
      ' Noch kein Body Tag vorhanden
      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)
' Erstellt ein HTML Tag für das Image
  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)
' Erstellt ein HTML Tag für den Background Sound
  Obj.Tag = "<bgsound src='cid:" & Obj.Key & "'>"
End Sub

Private Sub AddAttachment(Obj As EmbeddedObj)
' Fügt der Mail eine Datei als eingebettete Anlage
' hinzu und versteckt diese.
  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)
' Fügt dem Quelltext der Mail ein Tag an der zuvor
' ermittelten Position hinzu.
  m_Buffer = left$(m_Buffer, m_StartPos - 1) _
              & Tag & _
              right$(m_Buffer, Len(m_Buffer) - m_EndPos)
  m_SafeMail.HTMLBody = m_Buffer
End Sub