Discussion :

[ProgElecT]

Il est curieux que le composant RichTextBox ne contient pas de commande permettant de faire du surlignage.
Suite à la question posé ICI , j’ai essayé de trouver une solution passe partout.

Voici le résulta.
Sur un Form, 1 « RichTextBox1 », 1 « label1 », 2 CommandButton « Command1 » et « Command2 »,
1 « Frame1 », dans ce Frame1, au moins 2 Label nommés LabCoul, indexé de 0 à 1 ou plus, moi dans ce projet de démonstration, j’en ai mis 22, chacun d’une couleur (BackColor) différentes qui servent pour le choix de la couleur de surlignage.
Dans Form_Load, tout est initialisé (placement dimensionnement ….)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
Option Explicit
Dim R As Byte, G As Byte, B As Byte
Dim T As Long, U As Long, V As Long
Dim OldSelStart As Long, OldLen As Long
 
Private Sub Form_Load()
'placement, dimensionnement des composants
Me.Width = 8415: Me.Height = 5520
Label1.Move 60, 0, 885, 195: Label1.Caption = "Surligner :": Label1.FontBold = True
Command1.Move 30, 210, 1305, 345: Command1.Caption = "La selection"
Command2.Move 1380, 210, 1305, 345: Command2.Caption = "La ligne"
RichTextBox1.Move 30, 540, 8205, 4515: RichTextBox1.AutoVerbMenu = True
Frame1.Move 2820, 30, 5385, 495
Frame1.FontBold = True
Frame1.Caption = "Couleur de surlignage ->"
LabCoul(0).Caption = "": LabCoul(0).Move 2220, 45, 225, 135
LabCoul(0).ToolTipText = "Un click pour surligner blanc"
LabCoul(1).Caption = "": LabCoul(1).Move 60, 210, 225, 225
For T = 2 To LabCoul.Count - 1
 LabCoul(T).Move LabCoul(T - 1).Left + 240, 210, 225, 225
 LabCoul(T).Caption = ""
Next T
 
'initialisation
LabCoul_Click 5
'3 exemples de texte non surligné
RichTextBox1.TextRTF = ""
'pas de surlignage ni de couleur pour l'encre
RichTextBox1.SelText = "Une phrase sens couleur" & vbCrLf
 
Dim Msg$
'2 phrases avec couleur encre et polices différentes .....
Msg$ = "{\rtf1\ansi\ansicpg1252\deff0\deflang1036{\fonttbl{\f0\fnil\fcharset0 Arial;}}"
Msg$ = Msg$ & "{\colortbl ;\red255\green0\blue0;\red0\green192\blue0;\red0\green0\blue255;}"
Msg$ = Msg$ & "\uc1\pard\cf1\b\fs20 ROUGE \cf2 VERT \cf3 BLEU}"
RichTextBox1.SelRTF = Msg$
 
RichTextBox1.SelText = vbCrLf
Msg$ = "{\rtf1\ansi\ansicpg1252\deff0\deflang1036{\fonttbl{\f0\fnil\fcharset0 Antique Olive;}{\f1\fnil\fcharset2 Webdings;}}"
Msg$ = Msg$ & "{\colortbl ;\red0\green192\blue0;\red0\green0\blue192;\red192\green0\blue192;}"
Msg$ = Msg$ & "\uc1\pard\f0\fs17 Texte noir, \b EN GRAS\b0 , \cf1 VERT\cf0 , \cf2\b\f1\fs28 autre fonte\b0 ,\cf0\f0\fs17  \b\i EN GRAS, \cf3\fs32 italic}"
RichTextBox1.SelRTF = Msg$
 
End Sub
 
Private Sub LabCoul_Click(Index As Integer)
'choix de la couleur pour le surlignage
If Index = 0 Then LabCoul(0).BackColor = &HFFFFFF: Exit Sub 'pour revenir au fond blanc
LabCoul(0).BackColor = LabCoul(Index).BackColor
End Sub
 
Private Sub Command1_Click()
'surligner la selection
OldSelStart = RichTextBox1.SelStart: OldLen = RichTextBox1.SelLength
SurligneSelection RichTextBox1
RichTextBox1.SelStart = OldSelStart: RichTextBox1.SelLength = OldLen: RichTextBox1.SetFocus
End Sub
 
Private Sub Command2_Click()
'surligner la ligne
'dans un premier temps, positionner le curseur sur la ligne a surligner
SurligneLaLigne RichTextBox1, RichTextBox1.GetLineFromChar(RichTextBox1.SelStart)
End Sub
 
Public Sub SurligneLaLigne(TextRichBox As RichTextBox, NumLigne As Integer)
Dim NumCaractDeb As Long, NumCaractFin As Long
OldSelStart = TextRichBox.SelStart: OldLen = TextRichBox.SelLength
'recherche du premier et dernier caractere de la ligne
TextRichBox.SelStart = 0: TextRichBox.SelLength = 640000
NumCaractDeb = -1: NumCaractFin = TextRichBox.SelLength
For T = 0 To NumCaractFin
 If TextRichBox.GetLineFromChar(T) = NumLigne Then
  If NumCaractDeb = -1 Then NumCaractDeb = T
 End If
 If NumCaractDeb <> -1 And TextRichBox.GetLineFromChar(T) > NumLigne Then
  NumCaractFin = T
  Exit For
 End If
Next T
TextRichBox.SelStart = NumCaractDeb: TextRichBox.SelLength = NumCaractFin - NumCaractDeb
SurligneSelection RichTextBox1
TextRichBox.SelStart = OldSelStart: TextRichBox.SelLength = OldLen: TextRichBox.SetFocus
End Sub
 
Public Sub SurligneSelection(TextRichBox As RichTextBox)
If TextRichBox.SelLength = 0 Then Exit Sub
Dim Memo As String 'pour contenir le TextRTF
Dim DebPara As String 'pour contenir la 1° ligne
Dim LignTblCouleur As String 'pour contenir la 2° ligne formatage couleur
Dim FinPara As String 'pour contenir la/les ligne(s) formatage texte
 
Memo = TextRichBox.SelRTF 'Memo du seltext y compris le formatage RTF
T = InStr(1, Memo, vbCrLf) 'Recherche de la fin de la 1°ligne
DebPara = Left(Memo, T + 1) 'recuperation de la 1° ligne
T = T + 2
If InStr(T, Memo, "{\colortbl") <> 0 Then
 'il y a deja un formatage couleur
 U = InStr(T, Memo, vbCrLf) 'recherche de la fin de la 2° ligne
 LignTblCouleur = Mid$(Memo, InStr(Memo, "{\colortbl"), U - T) 'recuperation de la 2° ligne
 'recuperation de(s) ligne(s) de texte formaté
 FinPara = Right$(Memo, Len(Memo) - (Len(DebPara) + Len(LignTblCouleur) + 2))
 Dim MemoLgnColor As String
 MemoLgnColor = LignTblCouleur
 'pour obtenir le nombre de couleur deja present
 LignTblCouleur = Replace(LignTblCouleur, "{\colortbl ;", "")
 LignTblCouleur = Replace(LignTblCouleur, ";}", "")
 Dim TableauCouleur() As String
 TableauCouleur = Split(LignTblCouleur, ";")
 'effacement de tous le(s) surlignage(s) existant(s)
 FinPara = Replace(FinPara, "\highlight0 ", "")
 FinPara = Replace(FinPara, "\highlight0", "")
 For V = LBound(TableauCouleur) To UBound(TableauCouleur)
  FinPara = Replace(FinPara, "\highlight" & CStr(V + 1) & " ", "")
  FinPara = Replace(FinPara, "\highlight" & CStr(V + 1), "")
 Next V
 LignTblCouleur = MemoLgnColor 'recuperation du formatage d'entrée
 'effacement du caractére fin de formatage ligne couleur
 LignTblCouleur = Replace(LignTblCouleur, "}", "")
 Else
 'pas de couleur ni pour l'encre, ni pour un surlignage
 FinPara = Right$(Memo, Len(Memo) - Len(DebPara))
 LignTblCouleur = "{\colortbl ;" 'entête ligne formatage couleur
 V = 0
End If
 
'ajout au formatage la couleur de surlignage
R = CStr(LabCoul(0).BackColor And &HFF&) 'recuperation de la composante rouge
G = CStr((LabCoul(0).BackColor And &HFF00&) / 2 ^ 8) '.... vert
B = CStr((LabCoul(0).BackColor And &HFF0000) / 2 ^ 16) '.... bleu
LignTblCouleur = LignTblCouleur & _
    "\red" & CStr(R) & "\green" & CStr(G) & "\blue" & CStr(B) & _
    ";}" & vbCrLf
'ajout du formatage surlignage
FinPara = "\highlight" & CStr(V + 1) & FinPara
'recomposition du SelTextRTF
Memo = DebPara & LignTblCouleur & FinPara
TextRichBox.SelRTF = Memo
End Sub
 
Private Sub RichTextBox1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = 1 And Shift = 2 Then 'Bt. Gauche + Ctrl
 SurligneSelection RichTextBox1
 RichTextBox1.SelLength = 0
End If
End Sub

Il suffit de sélectionner une couleur, de sélectionner une partie de texte (sur une ligne ou plusieurs) ou de placer le curseur sur la ligne que l’on veut surligner puis de cliquer le bouton voulut.
Bien entendu, il est possible de surligner directement par code, sens intervention de l’utilisateur du programme.

Toutes critiques, sujétions .......

Motif de la modification du code
Les Subs SurligneSelection et SurligneLaLigne prennent en compte un RichTextBox quelconque passé en 1° parametre.
Ajout du code pour surligner avec la souris.

[DarkVader]

Bonjour,

Il me semble qu'il y a plus simple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
 
Private Const LF_FACESIZE = 32
Private Type CHARFORMAT2
    cbSize                              As Integer
    dwMask                              As Long
    dwEffects                           As Long
    yHeight                             As Long
    yOffset                             As Long
    crTextColor                         As Long
    bCharSet                            As Byte
    szFaceName(0 To LF_FACESIZE - 1)    As Byte
 
    wWeight                             As Integer
    sSpacing                            As Integer
    crBackColor                         As Long
    lLCID                               As Long
    dwReserved                          As Long
    sStyle                              As Integer
    bUnderlineType                      As Byte
    bRevAuthor                          As Byte
    bReserved1                          As Byte
End Type
 
Private Declare Function SendMessageA Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
 
Public Sub SurligneSelection(TextRichBox As RichTextBox, Optional vbColor As ColorConstants = vbYellow)
    Dim cf As CHARFORMAT2
    Const SCF_SELECTION     As Long = &H1
    Const EM_SETCHARFORMAT  As Long = &H444
    Const CFM_BACKCOLOR     As Long = &H4000000
 
    With cf
        .cbSize = LenB(cf)
        .dwMask = CFM_BACKCOLOR
        .crBackColor = vbColor
    End With
 
    Call SendMessageA(TextRichBox.hWnd, EM_SETCHARFORMAT, SCF_SELECTION, ByVal VarPtr(cf))
End Sub

Comme la propriété defTextRTF est actualisée automatiquement, la méthode est cumulative.

[ProgElecT]

Tu as attendu 5 ans pour proposer ce code
Comme tu le sais sûrement, je suis un bricoleur, quand j'ai une demande à satisfaire, je bidouille.
Merci encore pour cette façon de faire nettement plus propre que se que j'avais proposé.

[DarkVader]

Ben je suis tombé dessus que ce matin et les contributions ne sont pas ce que je parcours le plus souvent
je suis d'ailleurs tombé dessus par hasard en faisant une recherche sur google