Coloriage synthaxique d'un code vb

Commenter

Contenu du snippet

Pour colorier un code de VB dans un richtextbox, il est dépendant du control mais la prochaine version qui n'est pas très fiable n'aura plus besoin il reconnait entre les "", les (), et les keyWord

Mettez sa dans un module

Source / Exemple : 


'*****************************************
'                                        *
'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

Conclusion :


Le code n'est pas très claire mais pour la prochaine génération du module indépendant, je vais me reprendre.

A voir également

S'inscrire maintenant

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.

Du même auteur (cs_max12)