COLORISATION SYNTAXIQUE

'Cette variable sert à ne pas réappeler
' une procédure en cours...
Private AntiRecursif As Boolean

Private CoulRouge As Byte
Private CoulVerte As Byte
Private CoulBleue As Byte
Private Couleur As Long

Private CoulRougeElement As Byte
Private CoulVerteElement As Byte
Private CoulBleueElement As Byte
Private CouleurElement As Long

Private varItem As Long



'================================================================
' INITIALISATION DU PROGRAMME
'================================================================
Private Sub Form_Load()
 varItem = 0
End Sub
'================================================================
'================================================================
'================================================================



'================================================================
' GESTION DES COULEURS
'================================================================
Private Sub HScrollRouge_Change(): Call HScrollRouge_Scroll: End Sub
Private Sub HScrollRouge_Scroll()
 CoulRouge = HScrollRouge.Value
 'Note: Cstr permet de convertir un nombre
 ' en texte sans ajouter d'espace avant
 ' comme le fait Str().
 ztxRouge.Text = CStr(CoulRouge)
 Call CouleurChanged
End Sub
Private Sub HScrollVerte_Change(): Call HScrollVerte_Scroll: End Sub
Private Sub HScrollVerte_Scroll()
 CoulVerte = HScrollVerte.Value
 ztxVerte.Text = CStr(CoulVerte)
 Call CouleurChanged
End Sub
Private Sub HScrollBleue_Change(): Call HScrollBleue_Scroll: End Sub
Private Sub HScrollBleue_Scroll()
 CoulBleue = HScrollBleue.Value
 ztxBleue.Text = CStr(CoulBleue)
 Call CouleurChanged
End Sub
Private Sub CouleurChanged()
 'Notes :
 'La fonction RGB permet d'obtenir le numéro d'une couleur
 ' en fonction des 3 composantes rouge, vert et bleu.
 ' Ce nombre est compris (lorsqu'on travail en 24 bits comme
 ' dans la pluspart des cas) entre 0 et 16'777'215.
 ' 24 bits = 2 puissance 24 = 16'777'216 couleurs possibles
 ' La variable devra donc être de type Long et non de de type
 ' Integer. Par contre, les sub-pixels, eux, varient de 0 à 255
 ' (soit 256 nuances) et sont donc de type Byte.
 'La fonction CByte convertie un texte en nombre de type Byte justement.
 Couleur = RGB(CByte(ztxRouge.Text), CByte(ztxVerte.Text), CByte(ztxBleue.Text))
 ShapeCouleur.BackColor = Couleur
End Sub
'================================================================
'================================================================
'================================================================



'================================================================
' GESTION DE LA LISTE
'================================================================
Private Sub ztxElement_KeyUp(KeyCode As Integer, Shift As Integer)
 'Static veut dire que la variable sera conservée
 ' après chaque appel de cette procédure.
 'Autrement dit, elle ne sera pas détruite à la fin.
 'On utilise cette technique parce que cette procédure
 ' est appelée souvent.
 Static t As Integer  'Variable temporaire
 Static varModifier As Boolean  'Variable de détection
 
 If AntiRecursif = True Then Exit Sub
 AntiRecursif = True
 
 'Dès qu'on appuye sur une touche,
 If ztxElement.Text = "" Then
  'Désactive le bouton Ajouter et Modifier s'il n'y a pas de texte
  btnAjouter.Enabled = False
  btnModifier.Enabled = False
 Else
  'S'il y a du texte :
  'Il faut parcourir la liste pour savoir
  ' si ce texte existe déjà ou non.
  'S'il existe déjà, on active le bouton Modifier
  ' et on désactive le bouton Ajouter.
  'Dans le cas contraire, on fait l'inverse.
  varModifier = False
  If ListeDesMots.ListCount > 0 Then
   'Ne teste ça que si il y au moins un mot dans la liste
   For t = 0 To (ListeDesMots.ListCount - 1)
    If ListeDesMots.List(t) = ztxElement.Text Then varModifier = True: Exit For
   Next t
  End If
  If varModifier = True Then
   btnModifier.Enabled = True
   btnAjouter.Enabled = False
  Else
   btnModifier.Enabled = False
   btnAjouter.Enabled = True
  End If
 End If
 
 AntiRecursif = False
End Sub

Private Sub btnAjouter_Click()
 'Test de sécurité...
 If ztxElement.Text = "" Then Exit Sub
 
 varItem = varItem + 1
 ListeDesMots.AddItem ztxElement.Text
 ListeDesCouleurs.AddItem CStr(CouleurElement)
 ListeDesMots.ItemData(ListeDesMots.NewIndex) = varItem
 ListeDesCouleurs.ItemData(ListeDesCouleurs.NewIndex) = varItem
 ListeDesMots.ListIndex = ListeDesMots.NewIndex
 
 btnModifier.Enabled = True
 btnAjouter.Enabled = False
 btnSupprimer.Enabled = True
End Sub

Private Sub btnSupprimer_Click()
 Static t As Long
 
 If ListeDesMots.ListIndex < 0 Then btnSupprimer.Enabled = False: Exit Sub
 
 For t = 0 To (ListeDesCouleurs.ListCount - 1)
  If ListeDesMots.ItemData(ListeDesMots.ListIndex) = ListeDesCouleurs.ItemData(t) Then
   ListeDesCouleurs.RemoveItem t
   Exit For
  End If
 Next t
 
 t = ListeDesMots.ListIndex
 ListeDesMots.RemoveItem ListeDesMots.ListIndex
 If ListeDesMots.ListCount < 1 Then
  ztxElement.Text = ""
  CouleurElement = 0
  ShapeCouleurElement.BackColor = 0
  btnModifier.Enabled = False
  btnAjouter.Enabled = False
  btnSupprimer.Enabled = False
 Else
  If t > (ListeDesMots.ListCount - 1) Then t = (ListeDesMots.ListCount - 1)
  ListeDesMots.ListIndex = t
  btnModifier.Enabled = True
  btnAjouter.Enabled = False
  btnSupprimer.Enabled = True
 End If

End Sub

Private Sub btnModifier_Click()
 Static t As Long
 
 If ztxElement = "" Then btnModifier.Enabled = False: Exit Sub
 
 For t = 0 To (ListeDesCouleurs.ListCount - 1)
  If ListeDesCouleurs.ItemData(t) = ListeDesMots.ItemData(ListeDesMots.ListIndex) Then
   ListeDesCouleurs.ItemData(t) = CouleurElement
  End If
 Next t
End Sub

Private Sub btnChangerCouleur_Click()
 ShapeCouleurElement.BackColor = Couleur
 CouleurElement = Couleur
End Sub

Private Sub ListeDesMots_Click()
 Static BackCouleur As Long
 Static t As Long
 
 If ListeDesMots.ListIndex < 0 Then
  ztxElement.Text = ""
  CouleurElement = 0
  ShapeCouleurElement.BackColor = 0
  btnModifier.Enabled = False
  btnAjouter.Enabled = False
  btnSupprimer.Enabled = False
 Else
  ztxElement.Text = ListeDesMots.List(ListeDesMots.ListIndex)
  For t = 0 To (ListeDesCouleurs.ListCount - 1)
   If ListeDesCouleurs.ItemData(t) = _
      ListeDesMots.ItemData(ListeDesMots.ListIndex) Then _
      CouleurElement = CLng(ListeDesCouleurs.List(t))
  Next t
  ShapeCouleurElement.BackColor = CouleurElement
  btnModifier.Enabled = True
  btnAjouter.Enabled = False
  btnSupprimer.Enabled = True
 End If
End Sub



'================================================================
' COLORATION SYNTAXIQUE
'================================================================
'Note: Cette méthode pourait aussi, pour rendre l'utilisation
' moins lourde, se lancer toutes les x millisecondes via
' un timer. Pour cela, il faudrait placer tout ce code
' dans la procédure d'événement du timer...

Private Sub RichTextBox1_KeyPress(KeyAscii As Integer)
 'Méthode par recherche :
 '(méthode lente mais c'est pour l'exemple)
 Static t As Single
 Static tt As Single
 Static TextRechercher As String
 Static Position As Single
 Static varDebut As Single
 Static Coul As Long
 Static RechercheTerminer As Boolean
 
 'La méthode consiste à recherche tous les mots de la liste
 ' et à reconsituer les balises RTF.
 'Note :  plus il y a de mots, plus le programme sera lent!
 
 'Tout d'abord, on récupère la position actuelle du curseur.
 Position = RichTextBox1.SelStart
 
 'Efface toutes les couleurs du texte
 ' Note: une méthode plus fine pourrait être trouvée...
 RichTextBox1.SelStart = 1
 RichTextBox1.SelLength = Len(RichTextBox1.Text)
 RichTextBox1.SelColor = 0  'Encre Noir par défaut...
 'Un autre moyen :
 'RichTextBox1.TextRTF = RichTextBox1.Text
 
 'S'il n'y a aucun mot, on sort.
 If ListeDesMots.ListCount < 1 Then
  RichTextBox1.SelStart = Position
  Exit Sub
 End If
 
 For t = 0 To (ListeDesMots.ListCount - 1)
  RechercheTerminer = False
  TextRechercher = ListeDesMots.List(t)
  For tt = 0 To (ListeDesCouleurs.ListCount - 1)
   If ListeDesCouleurs.ItemData(tt) = ListeDesMots.ItemData(t) Then _
      Coul = ListeDesCouleurs.List(tt): Exit For
  Next tt
  varDebut = 1
  RichTextBox1.SelStart = varDebut
  Do
   'rtfMatchCase = Respecter la casse
   ' (c.a.d. les majuscules et les minuscules)
   ' Puisque la "Fin" est omise, toutes les recherches
   ' s'effecturons jusqu'a la fin texte.
   'rtfWholeWord = Rechercher par mot.
   tt = RichTextBox1.Find(TextRechercher, varDebut, , rtfWholeWord + rtfMatchCase)
   If tt = -1 Then
    'Il n'y a plus d'occurrence
    RechercheTerminer = True
   Else
    'La recherche à aboutie. Il faut remplacer le mot
    ' par le mot + les balises RTF de couleur.
    'Il faut ensuite placer le curseur à la fin du
    ' mot pour poursuivre la recherche.
    RichTextBox1.SelColor = Coul
    varDebut = varDebut + RichTextBox1.SelLength
   End If
  Loop While RechercheTerminer <> True
 Next t
 
 RichTextBox1.SelStart = Position
End Sub
'================================================================
'================================================================
'================================================================



'================================================================
' NOTES DE FIN
'================================================================
' La routine de recherche n'est pas très fine (surtout s'agissant
' de la gestion des espaces et des cas particuliers) mais c'est
' à vous d'en faire ce que vous voudrez.
' Il ne reste plus qu'a rajouter la gestion de l'enregistrement
' des fichiers (RTF ou TXT).
' Notez que ma gestion des couleurs n'est pas très performante.
' Il vaudrait mieux utiliser des PictureBox et utiliser le
' contrôle ActiveX "Microsoft CommonDialog"...
' Je n'ai pas non plus filtré les entrées texte (p.ex. enlever
' les espaces de début et de fin des expressions).
'
' A VOUS DE JOUER !
'================================================================
'================================================================
'================================================================