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 476 fois - Téléchargée 319 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

Alan71
Messages postés
530
Date d'inscription
lundi 3 juin 2002
Statut
Membre
Dernière intervention
13 juin 2004
-
nickel, maintenant, la meme chose en js (ca me lourde de le fer)
SupraDolph
Messages postés
196
Date d'inscription
samedi 12 janvier 2002
Statut
Membre
Dernière intervention
1 septembre 2008
1 -
je ne connai pas très bien le js si qqn ve le fair ...
DHKold
Messages postés
153
Date d'inscription
vendredi 6 décembre 2002
Statut
Membre
Dernière intervention
29 mai 2005
-
Très bien $-) Juste un ptit truc:
R1.Text = "Private Sub Command1_Click()"

il met le sub en bleu, alors qu'il se trouve entre "", faudrait arranger cela autrement c ok.
Bye... DHKold
jpujol95
Messages postés
60
Date d'inscription
dimanche 20 octobre 2002
Statut
Membre
Dernière intervention
5 septembre 2004
1 -
ca sert a rien sans etre mechant...
cs_BFR
Messages postés
88
Date d'inscription
mardi 30 juillet 2002
Statut
Membre
Dernière intervention
1 mars 2008
-
c'est une autre méthode de colorisation que je ne connaissais pas.
très beau travail ,ou à tu trouver la doc pour la colorisation du Richtexbox
bonne continuation
A++

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.