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

Télécharger le projet
Commenter

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.
Télécharger le projet

Codes Sources

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 (SupraDolph)