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: Übersicht der im Tipp unterstützten Smiley-Tags
|