Couleur vb change la couleur d'un document pour lui donner un style vb

Soyez le premier à donner votre avis sur cette source.

Vue 4 499 fois - Téléchargée 320 fois

Description

Colorise du text comme visual basique

pour ceux qui comme moi conservent des fichier script pour se rappeler de bout de code peut utiliser ...

ce code est le plus rapide que j'ai réussi a fait en fait j'utilise les propriètés de la richtextbox.(au debut je selectionnai un mot puis je le colorisai)

SupraDolph

Source / Exemple :


'il faut 1 richtextbox (R1) et un commandboutton (Command1),9 VScroll(Vscroll1(n) n[0;8]),4 label(label1,label2,label3,label5)

Private Type RVB
    R As Integer
    V As Integer
    B As Integer
End Type

Private Sub ColorisationVB(R1 As RichTextBox, RGBCouleurComentaire As RVB, RGBCouleurFonction As RVB, RGBCouleurTexte As RVB)
On Error Resume Next
Dim Debut As Long, Fin As Long, Text As String, Nombre As Long, i As Long, Pos As Long
Dim var As Long, ListMot As Variant, Temp As Long, Texttmp As String, j As Long
Dim CouleurTexte As String, CouleurFonction As String, CouleurComentaire As String

Text = R1.Text                      'On utilise une variable pour la rapiditée
Text = Replace(Text, "\", "\\")     'On Modifie tous les caractères spéciaux
Text = Replace(Text, "{", "\{")     'à la richtextbox
Text = Replace(Text, "}", "\}")
Text = " " & Text & " "

'<><><><><><><>
'<> Fonction <>
'<><><><><><><>

'Liste des mots a mettre en Fonction :
ListMot = Array("And", "As", "Boolean", "ByRef", "Byte", "ByVal", "Call", "Case" _
                , "Case Is", "Close", "Const", "Currency", "Date", "Declare", "Dim", "Do" _
                , "DoEvents", "Double", "Else", "ElseIf", "End", "Enum", "Error", "Events" _
                , "Exit", "Exit For", "False", "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", "Step", "String", "Sub", "Then", "To" _
                , "True", "Type", "Variant", "Wend", "While", "With")
                
For i = 0 To UBound(ListMot)
    Fin = 1
    Do
        Debut = InStr(Fin, Text, ListMot(i), vbTextCompare)
        Temp = Debut
        If Debut <> 0 Then
            Fin = Debut + Len(ListMot(i))
            If Mid(Text, Debut - 1, 1) = " " Or Mid(Text, Debut - 2, 2) = vbCrLf Or Mid(Text, Debut - 1, 1) = "(" Or Mid(Text, Debut - 1, 1) = ")" Or Mid(Text, Debut - 1, 1) = "," Or Mid(Text, Debut - 1, 1) = ":" Then
                If Mid(Text, Fin, 1) = " " Or Mid(Text, Fin, 2) = vbCrLf Or Mid(Text, Fin, 1) = "(" Or Mid(Text, Fin, 1) = ")" Or Mid(Text, Fin, 1) = "," Or Mid(Text, Fin, 1) = ":" Then
                    Do
                        If Mid(Text, Temp - 2, 2) = vbCrLf Then Exit Do             'Recherche un retour à la ligne
                        Temp = Temp - 2
                    Loop
                    Nombre = 0
                    For j = 0 To Debut - Temp - 1
                        If Right(Mid(Text, Temp, Debut - Temp - j), 1) = """" Then Nombre = Nombre + 1 'Compte le nombre de "
                    Next j
                    Texttmp = Mid(Text, Temp, Debut - Temp)
                    If (Nombre Mod 2 = 0) And (InStr(1, Texttmp, "'", vbTextCompare) = 0) Then         's'il y en a un nombre paire (ce n'est pas du text) et que ce n'est pas du commentaire
                        deb = Mid(Text, 1, Debut - 1)
                        col = Mid(Text, Debut, Fin - Debut)
                        col = Replace(col, col, ListMot(i))
                        fini = Mid(Text, Fin, Len(Text))
                        Text = deb & "\cf2 " & col
                        Text = Text & "\cf3 " & fini
                    End If
                End If
            End If
        End If
    Loop While Debut <> 0
Next i

'<><><><><><><><>
'<> Comentaire <>
'<><><><><><><><>

Fin = 1
Supra:
    Debut = InStr(Fin, Text, "'", vbTextCompare)                    'Recherche les '
    Temp = Debut
    If Debut = 0 Then GoTo affiche                                  's'il n'y en a pas
    Fin = InStr(Debut, Text, vbCrLf, vbTextCompare)                 'Recherche un retour à la ligne
    If Fin = 0 Then Fin = Len(Text) + 1                             's'il n'y en a pas
    Do
        If Mid(Text, Temp - 2, 2) = vbCrLf Then Exit Do             'Recherche un retour à la ligne
        Temp = Temp - 2
    Loop
    Nombre = 0
    For i = 0 To Debut - Temp - 1
        If Right(Mid(Text, Temp, Debut - Temp - i), 1) = """" Then Nombre = Nombre + 1 'Compte le nombre de "
    Next i
    If Nombre Mod 2 <> 0 Then                                       's'il y en a un nombre impaire
        Fin = Debut + 1
        GoTo Supra
    End If
    deb = Mid(Text, 1, Debut - 1)
    col = Mid(Text, Debut, Fin - Debut)
    fini = Mid(Text, Fin, Len(Text))
    Text = deb & "\cf1 " & col
    Text = Text & "\cf3 " & fini
GoTo Supra

affiche:
Text = Replace(Text, vbCr, "\par ")
Text = Mid(Text, 2, Len(Text) - 1)

Comentaire = "{\colortbl ;\red" & RGBCouleurComentaire.R & "\green" & RGBCouleurComentaire.V & "\blue" & RGBCouleurComentaire.B
CouleurFonction = ";\red" & RGBCouleurFonction.R & "\green" & RGBCouleurFonction.V & "\blue" & RGBCouleurFonction.B
CouleurTexte = ";\red" & RGBCouleurTexte.R & "\green" & RGBCouleurTexte.V & "\blue" & RGBCouleurTexte.B & ";}"

Texttmp = "{\rtf1\ansi\ansicpg1252\deff0{\fonttbl{\f0\fnil\fcharset0 Courier New;}}"                        'Police utilisée
Texttmp = Texttmp & vbCrLf & Comentaire & CouleurFonction & CouleurTexte                                    'Couleurs utilisées
Texttmp = Texttmp & vbCrLf & "\viewkind4\uc1\pard\lang1036\f0\fs20 "                                        'Language
Texttmp = Texttmp & Text                                                                                    'On met le text
Texttmp = Texttmp & "\cf0\fs24" & vbCrLf & "\par }"                                                         'On indique que c'est la fin

'On enregistre
Open App.Path & "\Temp" For Output As #1
Print #1, Texttmp
Close #1
'On Charge
R1.LoadFile App.Path & "\Temp"
'On supprime le fichier temporaire
Kill App.Path & "\Temp"
End Sub

Private Sub Command1_Click()
Dim CoulComme As RVB, CoulFonct As RVB, CoulTexte As RVB
Dim Temp
Temp = Now
CoulComme.R = VScroll1(0).Value
CoulComme.V = VScroll1(1).Value
CoulComme.B = VScroll1(2).Value
CoulFonct.R = VScroll1(3).Value
CoulFonct.V = VScroll1(4).Value
CoulFonct.B = VScroll1(5).Value
CoulTexte.R = VScroll1(6).Value
CoulTexte.V = VScroll1(7).Value
CoulTexte.B = VScroll1(8).Value
ColorisationVB R1, CoulComme, CoulFonct, CoulTexte
DoEvents
Label5.Caption = "Convertion éffectuée en " & DateDiff("s", Temp, Now) & " Secondes"
End Sub

Private Sub Form_Load()
R1.Text = "Private Sub Command1_Click()" & vbCrLf & "'Ceci est un commantaire" & vbCrLf & """'Ceci n'est pas un commantaire""" & vbCrLf & "End Sub"
VScroll1_Change 1
VScroll1_Change 3
VScroll1_Change 6
End Sub

Private Sub VScroll1_Change(Index As Integer)
Select Case Index

    Case 0, 1, 2
    Label1.Caption = "Commentaire :" & vbCrLf & "RGB(" & VScroll1(0).Value & "," & VScroll1(1).Value & "," & VScroll1(2).Value & ")"
    Label1.ForeColor = RGB(VScroll1(0).Value, VScroll1(1).Value, VScroll1(2).Value)

    Case 3, 4, 5
    Label2.Caption = "Fonction :" & vbCrLf & " RGB(" & VScroll1(3).Value & "," & VScroll1(4).Value & "," & VScroll1(5).Value & ")"
    Label2.ForeColor = RGB(VScroll1(3).Value, VScroll1(4).Value, VScroll1(5).Value)

    Case 6, 7, 8
    Label3.Caption = "Texte :" & vbCrLf & " RGB(" & VScroll1(6).Value & "," & VScroll1(7).Value & "," & VScroll1(8).Value & ")"
    Label3.ForeColor = RGB(VScroll1(6).Value, VScroll1(7).Value, VScroll1(8).Value)
    
End Select
End Sub

Private Sub VScroll1_Scroll(Index As Integer)
VScroll1_Change Index
End Sub

Conclusion :


Plus de bug connu.

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Renfield
Messages postés
17280
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
21 juillet 2019
57 -
la methode est en fait très très simple !!!!!


Const EM_LINEFROMCHAR = &hC9

et tu fais un SendMessage :

NbLigne = SendMessage ( Rtf.hwnd , EM_LINEFROMCHAR , -1 , byval 0& )


et voila !!! c'est pas une methode lourde, et c'est instantané.... ;-)
SupraDolph
Messages postés
196
Date d'inscription
samedi 12 janvier 2002
Statut
Membre
Dernière intervention
1 septembre 2008
1 -
capoueidiablo : une methode asser lourde mais relativement simple a mettre en oeuvre est de faire une boucle qui a partir de la position de ton curseur (rtb.selpos ou qqc comme sa) teste caractère par caractère en reculant pour trouver un vbcrlf (ou ch(13) ) dès que tu le trouve ou si tu est au début du document tu mémorise la position. tu refait la meme chose en avançant (sauf que tu test si tu est a la fin du texte à la place du début).
fait attention car le vbcrlf prend 2 caractères (vbcr + vblf).
Jéspère que j'ai été clair.
Bonne Prog.
SupraDolph
capoueidiablo
Messages postés
316
Date d'inscription
jeudi 9 janvier 2003
Statut
Membre
Dernière intervention
1 février 2010
1 -
Renfield => tu devrai mettre un espace avant et après chaque mot à rechercher car si tu ecris des mots contenant une partie de ceux rehercher cela changerons quand meme de couleurs.

All => Vous ne sauriez pas comment je pourai faire pour recuperer la ligne courante dans une rtb par hasard ?
Renfield
Messages postés
17280
Date d'inscription
mercredi 2 janvier 2002
Statut
Modérateur
Dernière intervention
21 juillet 2019
57 -
petite mise a jour pour le changement de couleur de mots contenus dans un rtf ( ici , pas de detection des guillements ni des commentaires , attention , pour bien faire , il faudrait créer un parseur qui decoupe la chaine et applique le style , je vais en realiser un , mais pour le c , a suivre......)

ListMot = Array("And", "As", "Boolean", "ByRef", "Byte", "ByVal", "Call", "Case" _
, "Case Is", "Close", "Const", "Currency", "Date", "Declare", "Dim", "Do" _
, "DoEvents", "Double", "Else", "ElseIf", "End", "Enum", "Error", "Events" _
, "Exit", "Exit For", "False", "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", "Step", "String", "Sub", "Then", "To" _
, "True", "Type", "Variant", "Wend", "While", "With")

For Each Word In Words
a = RichTextBox1.Find(Word, 0)
While (a <> -1)
RichTextBox1.SelStart = a
RichTextBox1.SelLength = Len(Word)
RichTextBox1.SelColor = RGB(255, 0, 0)
a = RichTextBox1.Find(Word, a + Len(Word))
Wend
Next Word
SupraDolph
Messages postés
196
Date d'inscription
samedi 12 janvier 2002
Statut
Membre
Dernière intervention
1 septembre 2008
1 -
oui c pas trop mal je comptai le revoir totale ment pour le faire aussi dans un tableau. g un pote qui bosse dessus aussi .

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.