Gestion de smileys avec richtextbox

Soyez le premier à donner votre avis sur cette source.

Vue 9 052 fois - Téléchargée 1 090 fois

Description

Cette appli a deux fonctions :

- Donner une idée pour gérer des smileys pour faire une chat par exemple.

- Apporter une nouvelle solution au pb : insérer une image dans une RichTextBox.

Techniquement on trouve la création/lecture de fichiers avec Open et l'utilisation des CommonDialogs.

Source / Exemple :


''''''''''''''''''''''''''''''' DANS UNE FORM ''''''''''''''''''''''''''''''''''''''

Option Explicit

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'            APP REALISEE PAR FERREIROS SEBASTIEN ALIAS GREENGOLD
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Const PtIns As String = "{\pict\"   'Point d'insertion pour récupérer le contenu de l'image
Dim FSO As New FileSystemObject     'sert à manipuler les dossiers et fichiers, Projet > Références > Microsoft Scripting Runtime
Dim NomImg As String    'Nom du fichier image sélectionné par l'utilisateur
Dim ContenuImg As String    'Contenu des octets de l'image (Format RichTextFile)

Private Sub BtParcours_Click()
    Dim ch As String
   
    On Error GoTo GestionErreurs
    
    'Initialisation du CommonDialog
    CD.CancelError = True   'une erreur sera déclenchée si l'utilisateur clique sur le bouton annuler
    CD.DialogTitle = "Choisissez une image"
    CD.Flags = cdlOFNPathMustExist And cdlOFNFileMustExist
    CD.InitDir = App.Path & "\Smiles"
    CD.Filter = "Images (jpg ou gif)|*.jpg; *.jpeg ; *.gif"
    CD.ShowOpen
    If FSO.FileExists(CD.FileName) = True Then  'On vérifie l'existence du fichier
            
        'S'il y a du texte dans le presse papier, on l'affecte à ch
        If Clipboard.GetFormat(vbCFText) Then
            ch = Clipboard.GetText
        End If
        'Initialisation de la form
        PicSmile.Cls
        RtbSmile.Text = ""
        PicSmile.Picture = LoadPicture(CD.FileName) 'On copie l'image dans une PictureBox invisible
        'Copie de l'image dans la RichTextBox pas API
        Clipboard.Clear
        Clipboard.SetData PicSmile.Picture
        SendMessage RtbSmile.hwnd, WM_PASTE, 0, 0    'Insertion de l'image dans la RichTextBox
        Clipboard.Clear
        If Not ch = "" Then 'S'il y avait du texte dans le presse papier, on le recolle
            Clipboard.SetText ch
        End If
        RtbRtf.Text = RtbSmile.TextRTF
        NomImg = Left(CD.FileTitle, Len(CD.FileTitle) - 4)
        Frame2.Enabled = True
    Else
        Err.Raise vbObjectError + 513   'On déclenche une erreur
    End If
    Exit Sub

GestionErreurs:
    
    Select Case Err.Number
        Case vbObjectError + 513          'Le fichier voulu n'existe pas
            MsgBox "Ce fichier n'existe pas, veuillez en choisir un autre.", vbExclamation, "Fichier introuvable !"
        Case cdlCancel                  'Clic sur le bouton annuler de la CommonDialog
            'MsgBox "Clic sur Annuler !"
    End Select
End Sub

'Je sais que la déclaration de l'image commence par "{\pict\" et finit par "}"
'On va faire une recherche de sous-chaine
Private Sub BtRecup_Click()
    Dim PosDeb As Integer
    Dim PosFin As Long
    
    'Recherche de la position de la sous-chaine
    PosDeb = InStr(1, RtbRtf.Text, PtIns, vbTextCompare)
    PosFin = Len(RtbRtf.Text) - 10  'InStr(PosDeb, RtbRtf.Text, "}", vbTextCompare)
    'Extraction de la sous-chaine
    ContenuImg = Mid(RtbRtf.Text, PosDeb, PosFin - PosDeb + 1)
    RtbPicRtf.Text = ContenuImg
End Sub

Private Sub BtConst_Click()
    Dim Chemin As String
    Dim Msg As VbMsgBoxResult
    
    Chemin = App.Path & "\Fichiers .picrtf\" & NomImg & ".picrtf"
    While FSO.FileExists(Chemin) = True
        Msg = MsgBox("Attention le fichier " & NomImg & ".picrtf" & " existe déjà, il va être écrasé, voulez-vous le renomer ?", vbExclamation + vbYesNo)
        If Msg = vbYes Then
            NomImg = InputBox("Donnez un nom au nouveau fichier", , NomImg)
            Chemin = App.Path & "\Fichiers .picrtf\" & NomImg & ".picrtf"
        Else
            Chemin = ""
        End If
    Wend
    
    If Chemin = "" Then Chemin = App.Path & "\Fichiers .picrtf\" & Left(NomImg, Len(NomImg) - 4) & ".picrtf"

    Open Chemin For Output As #1    'Accès et création du fichier (type = séquentiel, mode = écriture)
        Print #1, ContenuImg        'écriture dans le fichier
    Close #1
    Frame2.Enabled = False
        
End Sub

Private Sub BtConv_Click()
    'Initialisation du CommonDialog
    'CD2.CancelError = True   'une erreur sera déclenchée si l'utilisateur clique sur le bouton annuler
    CD2.DialogTitle = "Choisissez le fichier.picrtf"
    CD2.Flags = cdlOFNPathMustExist And cdlOFNFileMustExist
    CD2.InitDir = App.Path & "\Fichiers .picrtf"
    CD2.Filter = "Fichiers .picrtf|*.picrtf"
    CD2.ShowOpen
    If FSO.FileExists(CD2.FileName) = True Then  'On vérifie l'existence du fichier
        Call Convertir(ZsSmile.Text, CD2.FileName, RtbMess, RtbDest)
    Else
        MsgBox "Erreur...", vbCritical
    End If
End Sub

Private Sub Convertir(ByVal Smile As String, ByVal PathFicPicRtf As String, _
                        ByVal RichTextBoxOrigine As RichTextBox, _
                        ByVal RichTextBoxDestination As RichTextBox)
'Smile = ":)" ou ";+}" ...... Attention de ne pas prendre une chaine présente dans l'en-tête du format RichTextFile
'PathFicPicRtf = Chemin complet du fichier.picrtf
'RichTextBoxOrigine = La RichTextBox qui contient le message à convertir
'RichTextBoxDestination = La RichTextBox qui contiendra les images
    
    Dim Interm As String
    Dim ChSmile As String   'chaine du .picrtf
    
    Open PathFicPicRtf For Input As #1
        While Not EOF(1)            'tant que non fin
            Line Input #1, Interm       'lecture
            ChSmile = ChSmile & Interm
        Wend
    Close #1

    RichTextBoxDestination.TextRTF = Replace(RichTextBoxOrigine.TextRTF, Smile, ChSmile, , , vbTextCompare)
End Sub

'''''''''''''''''''''''''''''''' DANS UN MODULE ''''''''''''''''''''''''''''''''

Option Explicit

'Sert à copier une image dans une RichTextBox (vide le presse papier !!)
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const WM_PASTE = &H302

Conclusion :


Le principe de fonctionnement est simple, on colle une image dans une RichTextBox, on extrait le codage de l'image du code RTF de la RichTextBox. Ensuite, on met le contenu de l'image extrait dans un fichier.picrtf (on aurait aussi pu le mettre dans une variable... ça reste à tester, surtout si on manipule des images volumineuses, peut-être que c plus performent... ?). Enfin, on utilise ce fichier, en écrivant son contenu directement dans le code RTF d'une RichTextBox.

Bon coding à tous ;)

Codes Sources

A voir également

Ajouter un commentaire Commentaires
Messages postés
192
Date d'inscription
vendredi 2 mars 2001
Statut
Membre
Dernière intervention
10 janvier 2006

J'ai une méthode peut etre plus simple pour afficher des smileys

Vous avez besoin de ::

1 Form
1 RichTextBox (RTB)
2 PictureBox (Temp_PIC et Smileys_PIC)
1 TextBox (Texte)
1 CommandButton (Command1)

Dans Smileys_Pic se trouve une image qui est un tableau de smileys

Voici le code ::

Public Sub ShowMessage(Msg As String)
Dim Smile As Variant
Dim Key As Byte
Dim SmilePos_CL As New Collection
Dim Cmp As Integer

'Scan toute la chaine de caractère
For i = 1 To Len(Msg)
Key = 0
'Boucle sur la collection des smileys
For Each Smile In Smileys_CL
'Si le smiley courant est détecté
If Mid(Msg, i, Len(Smile)) = Smile Then
'Ajoute le type et la position du smiley dans la collection
SmilePos_CL.Add Key
SmilePos_CL.Add i - 1 + Cmp
'Supprime le smiley détecté de la chaine
Msg = Left(Msg, i - 1) + " " + Right(Msg, Len(Msg) - (i + Len(Smile)))
Cmp = Cmp + 1
Exit For
End If
Key = Key + 1
Next
Next
'Affiche le texte épuré (sans smileys, ni graphique ni texte) dans le RTB
RTB.Text = Msg
'Ajoute les smileys détectés
For i = 1 To SmilePos_CL.Count Step 2
PasteSmiley SmilePos_CL(i), SmilePos_CL(i + 1)
Next
End Sub

Public Sub PasteSmiley(Key As Byte, Pos As Integer)
Dim x as byte
Dim y as byte

'Trouve la position du smiley selon son index
y = ((Key Mod 10)) * 16
x = Int(Key / 10) * 16
'Colle le smiley dans un picturebox temporaire
Temp_Pic.PaintPicture Smileys_PIC, 0, 0, , , x, y, 16, 16
PasteImage Temp_Pic, Pos

End Sub

Sub PasteImage(Pic As PictureBox, Pos As Integer)

'Vide le presse papier
Clipboard.Clear
'Colle le smiley dans le presse papier
Clipboard.SetData Pic.Image
'Position du smiley
RTB.SelStart = Pos
'Colle le smiley
SendMessage RTB.hwnd, WM_PASTE, 0, 0

End Sub

Private Sub Command1_Click()

ShowMessage Texte.Text

End Sub

Private Sub Form_Load()
Smileys_CL.Add ":)"
Smileys_CL.Add ";)"
Smileys_CL.Add ":p"
Smileys_CL.Add ":D"
Smileys_CL.Add "LOL"
Smileys_CL.Add ":$"
Smileys_CL.Add ":("
Smileys_CL.Add ":o"
Smileys_CL.Add ":O"
Smileys_CL.Add ">:O"
Smileys_CL.Add "8)"
End Sub

Voila tout, la taille des smileys et de 16*16 et le tableau de smileys et 10*20 dans mon exemple, mais seul les 11 premiers smileys sont ajoutés dans la collection, vu que c'est pour un exemple, pas besoin de plus!
Voila ma contrib, si vous avez des suggestions...
Messages postés
176
Date d'inscription
vendredi 29 octobre 2004
Statut
Membre
Dernière intervention
7 mars 2005

Bravo je cherchais cette source depuis un ptit moment !
Mais je suis sous VB5 et j'ai un peu galéré pour la faire fonctionner...
S'il y en a qui ont (ou ont eu) le même problème que moi, si ça peut aider, j'ai expliqué la démarche à suivre à cette adresse du forum :
http://www.vbfrance.com/forum.v2.aspx?ID=386211

@+
Messages postés
232
Date d'inscription
mercredi 25 octobre 2000
Statut
Membre
Dernière intervention
5 octobre 2012

Vos commentaires m'interroge sur le format du smiley sous Win98SE... En effet je rencontre un problème similaire simplement en placant un gif dans un picturebox puis en exécutant cela sous Win98SE. ! Il me semble qu'il y a quelque année cela fonctionné ! Maintenant je developpe sous XP mais mon soft, à cause de GIF, ne tourne plus sous WIN98 (cas d'un GIF dans un picturebox)... Une DLL manque ou ne serait plus à jour pour ouvrir un gif dans un soft VB6 ? Ne serait-ce pas du au SP6 de VB6 ?
Messages postés
8
Date d'inscription
mardi 13 mai 2003
Statut
Membre
Dernière intervention
20 août 2009

Ton code est très bien, je voudrais juste savoir si quelqu'un sait comment empêcher le redimensionnement d'une image dans un richtextbox. J'ai déjà trouver une source sur ce site mais ça ne fonctionne pas. Merci d'avance !
Messages postés
8
Date d'inscription
lundi 15 décembre 2003
Statut
Membre
Dernière intervention
1 avril 2004

simplement merci !!!
source tres pédagogique...
Afficher les 25 commentaires

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.