Coloriage synthaxique d'un code vb

Soyez le premier à donner votre avis sur cette source.

Snippet vu 6 800 fois - Téléchargée 55 fois

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

Ajouter un commentaire

Commentaires

Messages postés
1491
Date d'inscription
dimanche 19 novembre 2000
Statut
Modérateur
Dernière intervention
7 juillet 2014

Hum c'est vieux tout ceci, je ne suis pas particulièrement fière de ce code, j'ai presque envie de le désactiver. Enfin, ma bonne idée dans tout ça était le fait de transférer directement en RTF code (pourrait être du HTML a la limite)
Messages postés
34
Date d'inscription
lundi 10 juin 2002
Statut
Membre
Dernière intervention
20 octobre 2009

Salut,
Ce code me sert bien et fonctionne super.
Merci pour ce code.

Mais j'ai apporté une petite modification à la fonction IsCompleteWord.
j'ai modifié la ligne :

If Left(Texte, 1) " " Or Left(Texte, 1) Chr(10) Then

par

If Left(Texte, 1) " " Or Left(Texte, 1) vbTab Or Left(Texte, 1) = Chr(10) Then

car j'avais juste devant des "If" des tabulations et ils n'étaient pas coloriés.
Messages postés
78
Date d'inscription
lundi 13 mai 2002
Statut
Membre
Dernière intervention
4 mai 2008

Vraiment excellent.
GG à toi! :D
Je vais m'en servir pour un editeur de fichiers VBS ;)
Je laisse tes commentaires sans pb :)

++
Messages postés
1491
Date d'inscription
dimanche 19 novembre 2000
Statut
Modérateur
Dernière intervention
7 juillet 2014

J'ai simplement fait des tests pour les code. Sinon poru faire comme sur Word Toasty a déposer un code qui montre comment. Je crois que sa s'appelais : backcolor dans un richtextbox
Messages postés
1134
Date d'inscription
mercredi 2 octobre 2002
Statut
Membre
Dernière intervention
24 juillet 2011
1
J'aimerais savoir comment tu t'y es pris pour obtenir les codes à utiliser pour la coloration ? +Où puis-je les trouver (j'aimerais par exemple mettre en gras, en italique...) ? Est-il possible de colorer également l'arrière du mot à la manière de Word (comme si on avait utilisé un surligneur) ?

J'ai fait une ataptation de ton code en passant le texte non pas "lettre" par "lettre" mais en utilisant la fonction Split(Texte, " ") et en passant alors les mots en revue les uns après les autres.
Afficher les 11 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.