Smileys in der Richtextbox Wie man Text-Smilies in einer RichTextBox durch entsprechende Smiley-Icons ersetzt, das erfahren Sie hier.
Autor:   Hendrik Storck	Bewertung:     [ Jetzt bewerten ]	Views:  20.343
www.hs-software.info	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 11 Bewertung insgesamt: gut Durchschnittliche Bewertung: 4.3 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Mit diesem Sourcecode ist es möglich, "Text-Smilies" wie , , usw. durch entsprechende Bildchen zu ersetzen.

Hinweis: Der Sourcecode verwendet den Tipp von Michael Imhof Bilder in der RTF-Textbox

Platzieren Sie auf einer Form eine Richtextbox, einen Button sowie ein unsichtbares Picture-Objekt und fügen folgenden Code in die Form ein:

Option Explicit
 
' Benötigte API-Deklarationen
Private Declare Sub Sleep Lib "kernel32" ( _
  ByVal dwMilliseconds As Long)
 
Private Declare Function SendMessage Lib "user32" _
  Alias "SendMessageA" ( _
  ByVal hwnd As Long, _
  ByVal wMsg As Long, _
  ByVal wParam As Long, _
  lParam As Any) As Long
 
Private Const WM_PASTE = &H302

Public Sub Create_Smileys(RTF As Control)
  Dim Smileys() As String
  Dim SmileysFile() As String
  Dim Smilestring As String
  Dim SmileFileString As String
  Dim i As Integer
  Dim Pos As Long, Start As Long
  Dim IconPath As String
 
  Screen.MousePointer = vbHourglass
 
  ' Akt. Position im RTF merken
  Pos = RTF.SelStart
 
  ' Suche nach Smileys ab Stelle
  Start = 1
 
  ' Pfad, in dem die Bilddateien gespeichert sind
  IconPath = App.Path & "\smileys\"
 
  ' Smileys-Tags (Zeichenfolgen) - durch
  ' Leerzeichen getrennt
  Smilestring = ":) :-) :( :-( ;) ;-) " & _
    ":o :D :p :cool: :rolleyes: :mad:"
 
  ' Dateinamen der Bilder, durch die die Zeichenfolgen
  ' ersetzt werden sollen - durch Komma getrennt
  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"
 
  ' Strings zerlegen und in ein Array speichern (nur VB6)
  ' VB4/5: siehe http://www.vbarchiv.net/archiv/tipp_463.html
  Smileys = Split(Smilestring, " ")
  SmileysFile = Split(SmileFileString, ",")
 
   ' kleine Prüfung, ob gleiche Anzahl
  If UBound(Smileys) <> UBound(SmileysFile) Then
    MsgBox "Ungleiche Anzahl."
    Exit Sub
  End If
 
  ' Nach Smileys in der RichTextBox suchen:
  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
 
    ' Alle Smileys eines Type gefunden. Suche von vorn
    Start = 1
  Next i
 
  ' Textmarke wieder zurücksetzen
  RTF.SelStart = Pos
 
  Screen.MousePointer = vbNormal
End Sub

Private Sub CopyPictureToRTF(RTF As Control, Bild As Picture)
  ' Diese Funktion stamt von Michael Imhof
  ' Siehe vb@rchiv: http://www.vbarchiv.net/archiv/tipp_56.html
  ' Manchmal gibt es Probleme mit dem Zurückschreiben
  ' der Zwischenablage, in diesem Fall kann man die Zeilen
  ' Clipboard.... auskommentieren
 
  Dim Buf As Variant
  Dim Text As String
 
  If Clipboard.GetFormat(vbCFText) = True Then
    ' Wenn in der Zwischenablage Text ist,
    ' wird er in einem String gespeichert
    Text = Clipboard.GetText
  Else
    ' ansonsten in einer Variant-Variable
    Buf = Clipboard.GetData
  End If
 
  ' Zwischenablage löschen und Bild kopieren
  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 ' zur Sicherheit kurz warten
 
  ' Zwischenablage wieder löschen, da das Bild
  ' sonst in der Zwischenablage bleibt
  Clipboard.Clear
 
  ' Falls vor dem Kopieren des Bildes ein Text oder
  ' sonstiger Inhalt in der Zwischenablage war, schreiben wir
  ' diesen wieder zurück in die Zwischenablage
  If Text <> "" Then
    Clipboard.SetText Text
  Else
    If Buf <> 0 Then
      Clipboard.SetData Buf
    End If
  End If
End Sub

Private Sub Command1_Click()
  ' Alle Smiley-Tags durch Bildsymbole ersetzen
  Create_Smileys RichTextBox1
End Sub

Damit das Beispiel funktioniert, müssen Sie im Projektordner einen Unterordner smileys erstellen und die entsprechenden Smiley-Dateien dort ablegen:
 smileys.zip (7 KB)

Übersicht der im Tipp unterstützten Smiley-Tags

	oder
	oder
	oder ;)