COLORIAGE SYNTHAXIQUE D'UN CODE VB

'*****************************************
'                                        *
'Coloriage shythaxique selon max         *
'En cas de problème ou de modification   *
'Contacter a max12@iquebec.com           *
'SVP envoyer les modif par mail          *
'N'éffacer pas les commentaires SVP      *
'Bug à réglé si vous trouver la solution *
'Il serais bon de me m'envoyer les modif *
'                                        *
'*****************************************
Public a As Long, LaCouleur As Long
Public NoColorise As Boolean, InGuimette As Boolean, InParenthèse As Boolean, InComment As Boolean
Public LeTexteRTF As String, Texte1 As String, Debut As Long, RtfBox As RichTextBox
Declare Function GetTickCount Lib "kernel32" () As Long
Private Const Entete = "{\rtf1\ansi\ansicpg1252\deff0\deflang3084{\fonttbl{\f0\fnil\fcharset0 Courier New;}}" & vbCrLf & "{\colortbl ;\red0\green0\blue255;\red255\green0\blue0;\red0\green128\blue0;}"
Public Function TransfertRTF()
On Error Resume Next
NoColorise = False
InComment = False
a = 0
InGuimette = False
InParenthèse = False
Texte1 = RtfBox.Text
LeTexteRTF = Entete & vbCrLf & "\viewkind4\uc1\pard\fs20"
Debut = GetTickCount
Do
a = a + 1
'========================
'Détecte les keywords
If Mid(Texte1, a, 2) = "If" Or Mid(Texte1, a, 2) = "As" Or Mid(Texte1, a, 2) = "Do" Or Mid(Texte1, a, 2) = "In" Or Mid(Texte1, a, 2) = "Is" Or Mid(Texte1, a, 2) = "On" Or Mid(Texte1, a, 2) = "Or" Or Mid(Texte1, a, 2) = "To" Then
If IsCompleteWord(2, Mid(Texte1, a - 1, Len(Texte1))) = True Then
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf1 "
    If InComment = True And InGuimette = True Then LeTexteRTF = LeTexteRTF & "\cf3 "
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 2)
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf0 "
    a = a + 1
    Else
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
End If
ElseIf Mid(Texte1, a, 3) = "End" Or Mid(Texte1, a, 3) = "Sub" Or Mid(Texte1, a, 3) = "Dim" Or Mid(Texte1, a, 3) = "Xor" Or Mid(Texte1, a, 3) = "Dim" Or Mid(Texte1, a, 3) = "Tab" Or Mid(Texte1, a, 3) = "Set" Or Mid(Texte1, a, 3) = "Get" Or Mid(Texte1, a, 3) = "Let" Or Mid(Texte1, a, 3) = "New" Or Mid(Texte1, a, 3) = "Imp" Or Mid(Texte1, a, 3) = "For" Or Mid(Texte1, a, 3) = "Eqv" Or Mid(Texte1, a, 3) = "And" Or Mid(Texte1, a, 3) = "Lib" Then
If IsCompleteWord(3, Mid(Texte1, a - 1, Len(Texte1))) = True Then
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf1 "
    If InComment = True And InGuimette = True Then LeTexteRTF = LeTexteRTF & "\cf3 "
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 3)
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf0 "
    a = a + 2
    Else
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
End If
ElseIf Mid(Texte1, a, 4) = "Then" Or Mid(Texte1, a, 4) = "Else" Or Mid(Texte1, a, 4) = "Base" Or Mid(Texte1, a, 4) = "Byte" Or Mid(Texte1, a, 4) = "Call" Or Mid(Texte1, a, 4) = "Case" Or Mid(Texte1, a, 4) = "CCcur" Or Mid(Texte1, a, 4) = "CDbl" Or Mid(Texte1, a, 4) = "CDec" Or Mid(Texte1, a, 4) = "CInt" Or Mid(Texte1, a, 4) = "CLng" Or Mid(Texte1, a, 4) = "CStr" Or _
Mid(Texte1, a, 4) = "CVar" Or Mid(Texte1, a, 4) = "Enum" Or Mid(Texte1, a, 4) = "Line" Or Mid(Texte1, a, 4) = "Lock" Or Mid(Texte1, a, 4) = "Loop" Or Mid(Texte1, a, 4) = "LSet" Or Mid(Texte1, a, 4) = "Name" Or Mid(Texte1, a, 4) = "Next" Or Mid(Texte1, a, 4) = "Open" Or Mid(Texte1, a, 4) = "RSet" Or Mid(Texte1, a, 4) = "Seek" Or Mid(Texte1, a, 4) = "Stop" Or Mid(Texte1, a, 4) = "True" Or Mid(Texte1, a, 4) = "Type" Or Mid(Texte1, a, 4) = "Wend" Or Mid(Texte1, a, 4) = "With" Or Mid(Texte1, a, 4) = "Long" Or Mid(Texte1, a, 4) = "Goto" Or Mid(Texte1, a, 4) = "Read" Or Mid(Texte1, a, 4) = "Like" Then
If IsCompleteWord(4, Mid(Texte1, a - 1, Len(Texte1))) = True Then
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf1 "
    If InComment = True And InGuimette = True Then LeTexteRTF = LeTexteRTF & "\cf3 "
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 4)
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf0 "
    a = a + 3
    Else
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
End If
ElseIf Mid(Texte1, a, 5) = "Const" Or Mid(Texte1, a, 5) = "Alias" Or Mid(Texte1, a, 5) = "ByVal" Or Mid(Texte1, a, 5) = "CBool" Or Mid(Texte1, a, 5) = "CByte" Or Mid(Texte1, a, 5) = "CDate" Or Mid(Texte1, a, 5) = "Close" Or Mid(Texte1, a, 5) = "CVErr" Or Mid(Texte1, a, 5) = "Erase" Or Mid(Texte1, a, 5) = "Error" Or Mid(Texte1, a, 5) = "False" Or Mid(Texte1, a, 5) = "GoSub" Or Mid(Texte1, a, 5) = "Input" Or Mid(Texte1, a, 5) = "Print" Or Mid(Texte1, a, 5) = "Write" Or Mid(Texte1, a, 5) = "InStr" Or Mid(Texte1, a, 5) = "ByRef" Then
If IsCompleteWord(5, Mid(Texte1, a - 1, Len(Texte1))) = True Then
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf1 "
    If InComment = True And InGuimette = True Then LeTexteRTF = LeTexteRTF & "\cf3 "
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 5)
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf0 "
    a = a + 4
    Else
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
End If
ElseIf Mid(Texte1, a, 6) = "ElseIf" Or Mid(Texte1, a, 6) = "Binary" Or Mid(Texte1, a, 6) = "DefCur" Or Mid(Texte1, a, 6) = "DefDbl" Or Mid(Texte1, a, 6) = "DefDec" Or _
Mid(Texte1, a, 6) = "DefInt" Or Mid(Texte1, a, 6) = "DefLng" Or Mid(Texte1, a, 6) = "DefObj" Or Mid(Texte1, a, 6) = "DefSng" Or Mid(Texte1, a, 6) = "DefStr" Or Mid(Texte1, a, 6) = "DefVar" Or Mid(Texte1, a, 6) = "Double" Or Mid(Texte1, a, 6) = "Object" Or Mid(Texte1, a, 6) = "Option" Or Mid(Texte1, a, 6) = "Output" Or Mid(Texte1, a, 6) = "Public" Or Mid(Texte1, a, 6) = "Random" Or Mid(Texte1, a, 6) = "Resume" Or Mid(Texte1, a, 6) = "Return" Or Mid(Texte1, a, 6) = "Select" Or Mid(Texte1, a, 6) = "Single" Or Mid(Texte1, a, 6) = "Static" Or Mid(Texte1, a, 6) = "String" Or Mid(Texte1, a, 6) = "UBound" Or Mid(Texte1, a, 6) = "Unlock" Or Mid(Texte1, a, 6) = "ElseIf" Or Mid(Texte1, a, 6) = "Decimal" Or Mid(Texte1, a, 6) = "LBound" Or Mid(Texte1, a, 6) = "Global" Or Mid(Texte1, a, 6) = "Output" Or Mid(Texte1, a, 6) = "Resume" Then
If IsCompleteWord(6, Mid(Texte1, a - 1, Len(Texte1))) = True Then
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf1 "
    If InComment = True And InGuimette = True Then LeTexteRTF = LeTexteRTF & "\cf3 "
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 6)
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf0 "
    a = a + 5
    Else
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
End If
ElseIf Mid(Texte1, a, 7) = "Boolean" Or Mid(Texte1, a, 7) = "Compare" Or Mid(Texte1, a, 7) = "Declare" Or Mid(Texte1, a, 7) = "DefBool" Or Mid(Texte1, a, 7) = "DefByte" Or Mid(Texte1, a, 7) = "DefDate" Or Mid(Texte1, a, 7) = "Integer" Or Mid(Texte1, a, 7) = "Private" Or Mid(Texte1, a, 7) = "Nothing" Or Mid(Texte1, a, 7) = "Variant" Then
If IsCompleteWord(7, Mid(Texte1, a - 1, Len(Texte1))) = True Then
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf1 "
    If InComment = True And InGuimette = True Then LeTexteRTF = LeTexteRTF & "\cf3 "
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 7)
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf0 "
    a = a + 6
    Else
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
End If
ElseIf Mid(Texte1, a, 8) = "Currency" Or Mid(Texte1, a, 8) = "Function" Or Mid(Texte1, a, 8) = "Explicit" Then
If IsCompleteWord(8, Mid(Texte1, a - 1, Len(Texte1))) = True Then
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf1 "
    If InComment = True And InGuimette = True Then LeTexteRTF = LeTexteRTF & "\cf3 "
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 8)
    If InComment = False And InGuimette = False Then LeTexteRTF = LeTexteRTF & "\cf0 "
    a = a + 7
    Else
    LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
End If
Else
Select Case Mid(Texte1, a, 1)
'Début du coloriage des guimette
Case """"
    If InComment = False Then
        If InGuimette = False Then
        LeTexteRTF = LeTexteRTF & "\cf3 "
        InGuimette = True
        Else
        NoColorise = True
        LaCouleur = vbBlack
        InGuimette = False
        LeTexteRTF = LeTexteRTF & "\cf3 "
        LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
        End If
    End If
'Fin du coloriager des guilmette
'Début du coloriage des Parathèse
Case "'"
    LeTexteRTF = LeTexteRTF & "\cf3\i "
    InComment = True
Case Chr(10)
    LeTexteRTF = LeTexteRTF & vbCrLf & "\par "
    LeTexteRTF = LeTexteRTF & "\cf0\i0 "
    InComment = False
'Fin du coloriager des Commentaire
End Select
    If NoColorise = False Then LeTexteRTF = LeTexteRTF & Mid(Texte1, a, 1)
End If
'========================
    NoColorise = False
    cLog.Trace "Presque terminer"
    Form1.Caption = Int((a / Len(Texte1)) * 100)
    If a >= Len(Texte1) Then LeTexteRTF = LeTexteRTF & vbCrLf & "}": RtfBox.TextRTF = LeTexteRTF:  Exit Function 'RtfBox.TextRTF = LeTexteRTF: Form1.Caption = (GetTickCount - Debut) / 1000
    cLog.Trace "Terminer"
Loop
End Function
Public Function IsCompleteWord(NormLong As Long, Texte As String) As Boolean
    If Len(Left(Right(Texte, Len(Texte) - 1), InStr(Right(Texte, Len(Texte) - 1), " ") - 1)) = NormLong Or Len(Left(Right(Texte, Len(Texte) - 1), InStr(Right(Texte, Len(Texte) - 1), Chr(13)) - 1)) = NormLong Or Len(Left(Right(Texte, Len(Texte) - 1), InStr(Right(Texte, Len(Texte) - 1), ")") - 1)) = NormLong Then
        If Left(Texte, 1) = " " Or Left(Texte, 1) = vbTab Or Left(Texte, 1) = Chr(10) Then
            IsCompleteWord = True
        End If
    Else
        IsCompleteWord = False
    End If
End Function