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.
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.