Public Sub Create_Smileys(RTF As Control)
  Dim Smileys() As String
  Dim SmileysFile() As String
  Dim Smilestring As String
  Dim audiostring As String
  Dim SmileFileString As String
   Dim audioFileString As String
  Dim i As Integer
  Dim Pos As Long, Start As Long
  Dim IconPath As String
 
  Screen.MousePointer = vbHourglass
  Pos = RTF.SelStart
  Start = 1
  IconPath = App.Path & "\smileys\"
                     '  das meine ich 
  Smilestring = ":-) :-) :( :-( ;) ;-)  :o :D :p :cool: :rolleyes: :mad:"
  'Smilestring da sind smiley zeichen drin 
  SmileFileString = "smiley1.gif,smiley1.gif," & _
    "smiley2.gif,smiley2.gif," & _
    "smiley3.gif,smiley3.gif," & _
    "smiley4.gif,smiley5.gif," & _
    "smiley6.gif,smiley7.gif," & _
    "smiley8.gif,smiley9.gif"
 
  Smileys = Split(Smilestring, " ")
  SmileysFile = Split(SmileFileString, ",")
 
  If UBound(Smileys) <> UBound(SmileysFile) Then
    MsgBox "Ungleiche Anzahl."
    Exit Sub
  End If
 
  For i = LBound(Smileys) To UBound(Smileys)
    While RTF.Find(Smileys(i), Start - 1) >= 0
      Picture1.Picture = LoadPicture(Trim$(IconPath & SmileysFile(i)))
      RTF.SelStart = RTF.Find(Smileys(i), Start - 1)
      RTF.SelLength = Len(Smileys(i))
      Start = RTF.SelStart + RTF.SelLength + 1
      RTF.SelText = ""
      CopyPictureToRTF RTF, Picture1.Picture
    Wend
    Start = 1
  Next i
 
  RTF.SelStart = Pos
  Screen.MousePointer = vbNormal
End Sub
 
Private Sub CopyPictureToRTF(RTF As Control, Bild As Picture)
  Dim Buf As Variant
  Dim Text As String
 
  If Clipboard.GetFormat(vbCFText) = True Then
    Text = Clipboard.GetText
  Else
    Buf = Clipboard.GetData
  End If
 
  Clipboard.Clear
  Clipboard.SetData Picture1.Picture
  DoEvents
 
  ' Bild per SendMessage in RTF-Box einfügen
  SendMessage RTF.hwnd, WM_PASTE, 0, 0
  DoEvents
  Sleep 30 
 
 
  Clipboard.Clear
 
 
  If Text <> "" Then
    Clipboard.SetText Text
  Else
    If Buf <> 0 Then
      Clipboard.SetData Buf
    End If
  End If
End Sub