COULEUR VB

'----------------- Commentaire ----------------------------------------------------------------------------------------
' Créer : 21/05/2002
' Version 1.0   : Dernier modif le 07/04/2002

'Ajoute dans un formulaire
  - un richtextbox : rtbProgram
  - un boite texte : txtEtat
  - un progress bar : pgb
  - un commandbutton : cmdCouleur
'---------------------------------------------------------------------------------------------------------

Option Explicit

Const BLEU = 8650752
Const VERT = 33280
Const NOIR = 0

Dim ListMot

Private Sub Form_Load()
  ListMot = Array("And", "As", "Boolean", "ByRef", "Byte", "ByVal", "Call", "Case" _
    , "Case Is", "Close", "Const", "Declare", "Dim", "Do", "DoEvents", "Else" _
    , "ElseIf", "End", "Enum", "Error", "Events", "Exit", "Exit For", "False" _
    , "FileCopy", "For", "Function", "GoTo", "If", "Input", "Integer", "Line" _
    , "Long", "Loop", "New", "Next", "Not", "Object", "On", "Open", "Option Explicit" _
    , "Or", "Output", "Print", "Private", "Public", "Resume", "Select", "Set" _
    , "Single", "String", "Sub", "Then", "To", "True", "Type", "Wend", "While", "With")

  With rtbProgram.Font
    .Name = "Courier New"
    .Size = 8.5
    .Bold = False
    .Italic = False
  End With
  rtbProgram.Text = ""

End Sub

Private Sub cmdCouleur_Click()
Dim i As Long
Dim Debut As Long, DebutMot As Long
Dim posGuilD As Long, posGuilF As Long, nbGuil As Integer
Dim TextLine As String, LinePrec As String
  If rtbProgram.Text = "" Then Exit Sub
  txtEtat.Visible = True
  rtbProgram.Visible = False
  If Mid(rtbProgram.Text, 1, 2) <> vbCrLf Then rtbProgram.Text = vbCrLf & rtbProgram.Text
  'Permet d'avoir un progress bar fluide
  pgb.Min = 0
  pgb.Max = 100
  pgb.Visible = True
  pgb.Value = 0
  
  rtbProgram.SelStart = 0
  rtbProgram.SelLength = Len(rtbProgram.Text)
  With rtbProgram.Font
    .Name = "Courier New"
    .Size = 8.5
    .Bold = False
    .Italic = False
  End With
  'Recherche les mots en bleu
  DoEvents
  For i = 0 To UBound(ListMot)
    Debut = 1
    Do
      DebutMot = InStr(Debut, rtbProgram.Text, ListMot(i), vbBinaryCompare)
      If DebutMot <> 0 Then
        Debut = DebutMot + Len(ListMot(i))
        TextLine = Mid(rtbProgram.Text, DebutMot - 1, 1)
        If (Mid(rtbProgram.Text, DebutMot - 2, 2) = vbCrLf Or TextLine = " " Or TextLine = "(" Or TextLine = "(" Or TextLine = ")") Then
          TextLine = Mid(rtbProgram.Text, Debut, 1)
          If (Mid(rtbProgram.Text, Debut, 2) = vbCrLf Or TextLine = " " Or TextLine = "," Or TextLine = "(" Or TextLine = ")" Or TextLine = ":") Then
            rtbProgram.SelStart = DebutMot - 1
            rtbProgram.SelLength = Len(ListMot(i)) + 1
            rtbProgram.SelColor = BLEU
          End If
        End If
      End If
    Loop While DebutMot <> 0
    pgb.Value = (i + 1) * 75 / UBound(ListMot)
  Next i
  
  'Ce qui est compliqué là de dans c'est que j'utilise mais variable pour tout et n'importe quoi
  'Met en vert les commentaires
  Debut = 1
  Do
    'Verifie que le commentaire n'est pes entre Guillemet
    DebutMot = InStr(Debut, rtbProgram.Text, "'", vbTextCompare)
    If DebutMot <> 0 Then
      pgb.Value = 75 + (DebutMot * 25 / Len(rtbProgram.Text))
      'Enregistre la ligne qui contient le caractère "'" dans TextLine
      Debut = InStr(DebutMot, rtbProgram.Text, vbCrLf, vbTextCompare)
      posGuilD = InStrRev(rtbProgram.Text, vbCrLf, Debut)
      TextLine = Mid(rtbProgram.Text, posGuilD + 2, Debut - posGuilD - 2)
      'Recherche la position du guillemet suivant
      posGuilF = InStr(DebutMot - posGuilD, TextLine, Chr(34), vbTextCompare)
      'Compte le nombre de guillemet
      nbGuil = -1
      posGuilD = DebutMot - posGuilD
      Do
        nbGuil = nbGuil + 1
        posGuilD = InStrRev(TextLine, Chr(34), posGuilD) - 1
      Loop While posGuilD <> -1
      'S'il n'y a pas de guillemet devant ou s'il y en un nombre pair de guillemet
      'devant c'est bon, c'est un commentaire
      If posGuilF = 0 Or nbGuil Mod 2 = 0 Then
        rtbProgram.SelStart = DebutMot - 1
        rtbProgram.SelLength = Debut - DebutMot
        rtbProgram.SelColor = VERT
      End If
    End If
    Debut = DebutMot + 1
    DoEvents
  Loop While DebutMot <> 0

  pgb.Value = pgb.Max
  rtbProgram.SelStart = 0
  rtbProgram.SelLength = 0
  txtEtat.Visible = False
  rtbProgram.Visible = True
  rtbProgram.SetFocus
End Sub