Discussion :

[atc666]

j ai chercher en vain le tuto sur le richtextbox , mais j ai jamais reussi a le trouver
donc je viens poser ma question ici

j ai un soucis pour mettre en surbrillance toute les occurances du texte que je cherche
je fait une recherche sur plusieurs mot ( pas necessairement colle) donc deja je rame avec find
mais en plus ce petit coquin de find quand il va voir si il y a une autre occurance de mon text , il enleve la surbrillance de celui qu il avait deja trouve ...
je sais que je peut changer la couleur du texte trouver grace a selcolor mais comment faire pour changer sa couleur de fond ?
ex: faire que tout texte trouve soit affiche sur fond bleu
donc ma question est double

primo : comment chercher plusieurs mots dans le meme document ? sans utiliser plusieurs fois le find bien sur
secondo : comment garder ces textes en surbrillance ?

merci d avance a tous ceux qui me mettront sur une piste

[ProgElecT]

sans utiliser plusieurs fois le Find

A mon avis cela n'est pas possible, par contre tu peux le faire dans une boucle en incrémentant le 2éme paramètre de Find.
Pour le sur lignage, tu peux aussi aller voire RichTextBox et sur lignage.
Dans ta boucle pour chaque occurrence trouvée tu pourras utiliser le sur lignage proposé.

[atc666]

donc si je comprend bien faut passer par le code rtf ?
je vois que tu uttilise le mot highlight ca voudrai dire que ce que tu appelle surlignage , peut etre une mise en fond bleu et texte en noir ou en blanc ?

j ai un peu de mal a tout piger et bon vu l heure , je me dit que si je veut pouvoir encore etre eclaire par toi , j ai interet a vite poser mes questions

[ProgElecT]

Pour faire du sur-lignage d’un texte dans le composant RichtextBox pour un mot choisis par l’utilisateur du programme.
Il faut demander le mot à rechercher, puis parcourir l’ensemble du document avec la méthode Find.
Pour chaque occurrence, utiliser la procédure SurligneSelection.
Un exemple, Sur un Form, 1 RichtexBox et 2 CommandButtons

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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
Option Explicit
'--------------------- Trouvé sur DVP ---------------------
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
     ByVal hwnd As Long, _
     ByVal wMsg As Long, _
     ByVal wParam As Long, _
     ByRef lParam As Any) As Long
Private Const WM_PASTE As Long = &H302
'-----------------------------------------------------------
 
Dim R As Byte, G As Byte, B As Byte
Dim T As Long, U As Long, V As Long
Dim MotRechercher As String
 
Private Sub Frame1_Click()
If Frame1.Height = 255 Then
 Frame2.Height = 255: Frame2.Width = 2505
 Frame1.Height = 540: Frame1.Width = 5385: Frame1.ZOrder
 Else
 Frame1.Height = 255: Frame1.Width = 2505
End If
End Sub
Private Sub Frame2_Click()
If Frame2.Height = 255 Then
 Frame1.Height = 255: Frame1.Width = 2505
 Frame2.Height = 540: Frame2.Width = 5385: Frame2.ZOrder
 Else
 Frame2.Height = 255: Frame2.Width = 2505
End If
End Sub
Private Sub LabCoul_Click(Index As Integer)
'choix de la couleur pour le surlignage ou de l'encre
Select Case Index
 Case 0, 23: LabCoul(Index).BackColor = &HFFFFFF: Exit Sub
 Case Is < 23
 LabCoul(0).BackColor = LabCoul(Index).BackColor
 Frame1.Height = 255: Frame1.Width = 2505
 Case Is > 22
 LabCoul(23).BackColor = LabCoul(Index).BackColor
 Frame2.Height = 255: Frame2.Width = 2505
End Select
End Sub
 
Private Sub MenuPolice_Click()
Dim NomPolice As String
Dim SiezePolice As Integer
Dim BoldPolice As Boolean
Dim ItalicPolice As Boolean
Dim StrikeThruPolice As Boolean
Dim UnderlinePolice As Boolean
 
If RichTextBox1.SelLength <> 0 Then
 If IsNull(RichTextBox1.SelFontName) Then
  NomPolice = RichTextBox1.Font.Name
  SiezePolice = RichTextBox1.Font.Size
  BoldPolice = RichTextBox1.Font.Bold
  ItalicPolice = RichTextBox1.Font.Italic
  StrikeThruPolice = RichTextBox1.Font.Strikethrough
  UnderlinePolice = RichTextBox1.Font.Underline
  Else
  NomPolice = RichTextBox1.SelFontName
  SiezePolice = RichTextBox1.SelFontSize
  If Not IsNull(RichTextBox1.SelBold) Then
   BoldPolice = RichTextBox1.SelBold
   ItalicPolice = RichTextBox1.SelItalic
   StrikeThruPolice = RichTextBox1.SelStrikeThru
   UnderlinePolice = RichTextBox1.SelUnderline
   Else
   BoldPolice = RichTextBox1.Font.Bold
   ItalicPolice = RichTextBox1.Font.Italic
   StrikeThruPolice = RichTextBox1.Font.Strikethrough
   UnderlinePolice = RichTextBox1.Font.Underline
  End If
 End If
 Else
 NomPolice = RichTextBox1.Font.Name
 SiezePolice = RichTextBox1.Font.Size
 BoldPolice = RichTextBox1.Font.Bold
 ItalicPolice = RichTextBox1.Font.Italic
 StrikeThruPolice = RichTextBox1.Font.Strikethrough
 UnderlinePolice = RichTextBox1.Font.Underline
End If
 
CommonDialog1.Flags = cdlCFBoth Or cdlCFEffects
CommonDialog1.FontName = NomPolice
CommonDialog1.FontSize = SiezePolice
CommonDialog1.FontBold = BoldPolice
CommonDialog1.FontItalic = ItalicPolice
CommonDialog1.FontStrikethru = StrikeThruPolice
CommonDialog1.FontUnderline = UnderlinePolice
'CommonDialog1.Color = ColorPolice
CommonDialog1.CancelError = True
On Error Resume Next
CommonDialog1.ShowFont
 
If Err Then Exit Sub
If RichTextBox1.SelLength <> 0 Then
 RichTextBox1.SelFontName = CommonDialog1.FontName
 RichTextBox1.SelFontSize = CommonDialog1.FontSize
 RichTextBox1.SelBold = CommonDialog1.FontBold
 RichTextBox1.SelItalic = CommonDialog1.FontItalic
 RichTextBox1.SelStrikeThru = CommonDialog1.FontStrikethru
 RichTextBox1.SelUnderline = CommonDialog1.FontUnderline
 Else
 RichTextBox1.Font.Name = CommonDialog1.FontName
 RichTextBox1.Font.Size = CommonDialog1.FontSize
 RichTextBox1.Font.Bold = CommonDialog1.FontBold
 RichTextBox1.Font.Italic = CommonDialog1.FontItalic
 RichTextBox1.Font.Strikethrough = CommonDialog1.FontStrikethru
 RichTextBox1.Font.Underline = CommonDialog1.FontUnderline
End If
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
 
Private Sub RichTextBox1_SelChange()
If RichTextBox1.SelLength = 0 Then
 SmenuSurLigne(0).Enabled = False: SmenuColorer(0).Enabled = False
 SmenuSelrtF(0).Enabled = False
 Else
 SmenuSurLigne(0).Enabled = True: SmenuColorer(0).Enabled = True
 SmenuSelrtF(0).Enabled = True
End If
End Sub
 
Private Sub Smenufichier_Click(Index As Integer)
On Error GoTo GestErr
CommonDialog1.Filter = "Texte Formaté rtf (*.RTF)|*.RTF|Texte brut(*.txt)|*.txt"
CommonDialog1.Filter = CommonDialog1.Filter & "|Images (BMP,CUR,ICO,RLE,EMF,WMF,GIF,JPG)|*.BMP;*.CUR;*.ICO;*.RLE;*.EMF;*.WMF;*.GIF;*.JPG"
CommonDialog1.Filter = CommonDialog1.Filter & "|Tous fichiers(*.*)|*.*"
CommonDialog1.FilterIndex = 1
CommonDialog1.CancelError = True
Select Case Index
 Case 0 'ouvrir
  CommonDialog1.DialogTitle = "Ouvrir"
  CommonDialog1.ShowOpen
  Select Case Right(UCase(CommonDialog1.FileTitle), 3)
  Case "RTF"
   RichTextBox1.LoadFile CommonDialog1.FileName, rtfRTF
   Case "BMP", "CUR", "ICO", "RLE", "WMF", "EMF", "GIF", "JPG"
   RichTextBox1.TextRTF = ""
   Clipboard.Clear: Clipboard.SetData LoadPicture(CommonDialog1.FileName)
   SendMessage RichTextBox1.hwnd, WM_PASTE, 0, 0
  Case Else '"TXT"
   RichTextBox1.LoadFile CommonDialog1.FileName, rtfText
  End Select
 
 Case 1 'Insérer
  CommonDialog1.DialogTitle = "Insérer"
  CommonDialog1.ShowOpen
  Select Case Right(UCase(CommonDialog1.FileTitle), 3)
   Case "RTF"
    Dim MemoRTF As String, NewRTF As String
    MemoRTF = RichTextBox1.TextRTF
    OldSelStart = RichTextBox1.SelStart
    RichTextBox1.LoadFile CommonDialog1.FileName, rtfRTF
    NewRTF = RichTextBox1.TextRTF
    RichTextBox1.TextRTF = MemoRTF
    RichTextBox1.SelStart = OldSelStart
    RichTextBox1.SelRTF = NewRTF
   Case "BMP", "CUR", "ICO", "RLE", "WMF", "EMF", "GIF", "JPG"
    Clipboard.Clear: Clipboard.SetData LoadPicture(CommonDialog1.FileName)
    SendMessage RichTextBox1.hwnd, WM_PASTE, 0, 0
   Case Else '"TXT"
    Dim NumFich As Integer
    NumFich = FreeFile
    Open CommonDialog1.FileName For Input As #NumFich
    MemoRTF = Input(FileLen(CommonDialog1.FileName), NumFich)
    Close #NumFich
    RichTextBox1.SelText = MemoRTF
   End Select
 
 Case 2 'enregistrer
  CommonDialog1.DialogTitle = "Enregistrer"
  CommonDialog1.ShowSave
  If Right(UCase(CommonDialog1.FileTitle), 3) = "RTF" Then
   RichTextBox1.SaveFile CommonDialog1.FileName, rtfRTF
   Else
   RichTextBox1.SaveFile CommonDialog1.FileName, rtfText
  End If
 Case 3 'imprimer
  CommonDialog1.DialogTitle = "Imprimer"
  CommonDialog1.ShowPrinter
 Case 5: Unload Me 'quitter
End Select
Exit Sub
GestErr:
End Sub
 
Private Sub SmenuRechercher_Click(Index As Integer)
Select Case Index
 Case 0 'Rechercher pas à pas
 Case 1 'Suivant
 Case 2 'Dans tout le document
  MotRechercher = InputBox("Mot à rechercher ?", "Rechercher dans tout le document")
  If Trim(MotRechercher) = "" Then Exit Sub
  Rechercher
 Case 3 'Supprimer le sur-lignage
  If Trim(MotRechercher) = "" Then Exit Sub
  Dim OlcoulSurlign As OLE_COLOR, OldCoulEncre As OLE_COLOR
  'memorisation des couleur pour retablir par la suite
  OlcoulSurlign = LabCoul(0).BackColor: OldCoulEncre = LabCoul(23).BackColor
  LabCoul(0).BackColor = RichTextBox1.BackColor: LabCoul(23).BackColor = RichTextBox1.SelColor
  Rechercher
  'retablissment des choix de couleur
  LabCoul(0).BackColor = OlcoulSurlign: LabCoul(23).BackColor = OldCoulEncre
End Select
End Sub
Public Sub Rechercher()
  Dim Fin As Long, PosTrouver As Long
  RichTextBox1.SelStart = 0: RichTextBox1.SelLength = 64000
  Fin = RichTextBox1.SelLength: RichTextBox1.SelLength = 0
  PosTrouver = 1
  Do While PosTrouver <= Fin
   PosTrouver = RichTextBox1.Find(MotRechercher, PosTrouver, , rtfWholeWord)
   If PosTrouver <> -1 Then
    SurligneSelection RichTextBox1
    PosTrouver = PosTrouver + Len(MotRechercher)
    Else
    Exit Do
   End If
   DoEvents
  Loop
End Sub
Private Sub SmenuSelrtF_Click(Index As Integer)
If Index = 0 Then 'copier
 Clipboard.Clear: DoEvents: Clipboard.SetText RichTextBox1.SelRTF
 Else 'coller
 RichTextBox1.SelRTF = Clipboard.GetText
End If
End Sub
Private Sub SmenuColorer_Click(Index As Integer)
If Index = 0 Then RichTextBox1.SelColor = LabCoul(23).BackColor
End Sub
Private Sub SmenuSurLigne_Click(Index As Integer)
Select Case Index
 Case 0 ' la sélection
  OldSelStart = RichTextBox1.SelStart: OldLen = RichTextBox1.SelLength
  SurligneSelection RichTextBox1
  RichTextBox1.SelStart = OldSelStart: RichTextBox1.SelLength = OldLen: RichTextBox1.SetFocus
 Case 1 ' la ligne
  'dans un premier temps, positionner le curseur sur la ligne a surligner
  SurligneLaLigne RichTextBox1, RichTextBox1.GetLineFromChar(RichTextBox1.SelStart)
 Case 2 ' A la souris (bt.G + CTRL)
End Select
End Sub
 
Private Sub Form_Resize()
If Me.WindowState <> vbMinimized Then
 On Error Resume Next
 RichTextBox1.Move 30, 255, Me.Width - 165, Me.Height - 960
 If Err.Number Then Exit Sub
End If
End Sub
Private Sub Form_Load()
'placement, dimensionnement des composants
RichTextBox1.Move 30, 915, 8205, 4515: RichTextBox1.AutoVerbMenu = True
Frame1.Move 45, 0, 5385, 255
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, 270, 225, 225
For T = 2 To 22
 LabCoul(T).Move LabCoul(T - 1).Left + 240, 270, 225, 225
 LabCoul(T).Caption = ""
Next T
 
Frame2.Move 2610, 0, 5385, 255
Frame2.FontBold = True
Frame2.Caption = "Couleur pour le texte ->"
LabCoul(23).Caption = "": LabCoul(23).Move 2220, 45, 225, 135
LabCoul(23).ToolTipText = "Un click pour encre blanc"
LabCoul(24).Caption = "": LabCoul(24).Move 60, 270, 225, 225
For T = 25 To LabCoul.Count - 1
 LabCoul(T).Move LabCoul(T - 1).Left + 240, 270, 225, 225
 LabCoul(T).Caption = ""
Next T
 
Me.Width = 8415: Me.Height = 5520
 
'initialisation
LabCoul_Click 5
LabCoul_Click 26
RichTextBox1.TextRTF = ""
'3 exemples de texte non surligné
''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 Arial;}{\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
 
 
 
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

Apres le run Projet, tu colles un texte dedans (Btn droit dans le RichtextBox) puis tu click sur le premier bouton.
Je n'ai pas suffisament de temps pour commenter plus le code pour le moment, je reviendrai sûrement en fin de journée sur ce post.
A+

Motif de l'edit:
Nettoyage dans le code et un peu plus de commentaires.

[atc666]

je pense avoir trouver une solution pour me passer du find ...
si je fait un chtit replace ca doit le faire non ?
je mets un truc style

Code :

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

replace (richtextbox1.textRTF, lemotachercher,balisedecouleursurbrillance & lemotachercher & balise de retour a l affichage normal )

ca doit le faire comme ca non ?
me reste a trouver le code de la balise a coller devant et celui de celle a colle derriere.
parce que je suis desole mais je pige quedalle a ton soft la

deja le vois des labcoul , j ai supose que c etait des label renomme ainsi mais pas moyen de trouver ou les coller (j ai teste dans la frame et dehors sans resultat) ni de les voir une fois le soft lancer
or a ce que j ai compris c est eux qui me donne la couleur ou je vais utiliser pour l affichage modifier
moi l encre et le fond sont blanc donc le texte disparait
alors please

PS: desole pour mon absence , mais j ai fait une crise de palu , et j ai ete cloue au lit

[ProgElecT]

Désolé, je t'ai mis le code de la démonstration complète de l'utilisation du surlignage dans un RichTexBox, alors que j'avais préparé ce code adapté à ta demande (erreur de ma part du COPIER/COLLER).
Toujours un Form , 2 CommandButtons et 1 RichTextBox, les contrôles sont initialisés, placés et dimmensionnés dans le Form_Load donc tu les poses simplement sur le Form.

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
Option Explicit
Dim R As Byte, G As Byte, B As Byte
Dim T As Long, U As Long, V As Long
Dim MotRechercher As String
Dim CoulSurLign As OLE_COLOR
Private Sub Form_Load()
Command1.Caption = "Rechercher dans tout le document": Command2.Caption = "Supprimer le sur-lignage"
Command1.Move 120, 90, 3705, 360
Command2.Move 3945, 90, 1965, 360
RichTextBox1.AutoVerbMenu = True
'&HFFFFFF = 16777215 = blanc
RichTextBox1.BackColor = &HFFFFFF 'choisir toutes couleurs non Système
RichTextBox1.TextRTF = ""
RichTextBox1.Move 90, 540, 8490, 4905
Me.Height = 6135: Me.Width = 9045
End Sub
 
Private Sub Command1_Click()
MotRechercher = InputBox("Mot à rechercher ?", "Rechercher dans tout le document")
If Trim(MotRechercher) = "" Then Exit Sub
MotRechercher = Trim(MotRechercher)
'&HFF0000 =16711680 = bleu
CoulSurLign = &HFF0000 '***** ICI tu peux choisir une autre couleur de sur-lignage *********
R = CStr(CoulSurLign And &HFF&) 'recuperation de la composante rouge
G = CStr((CoulSurLign And &HFF00&) / 2 ^ 8) '.... vert
B = CStr((CoulSurLign And &HFF0000) / 2 ^ 16) '.... bleu
Rechercher
End Sub
Private Sub Command2_Click()
If MotRechercher = "" Then Exit Sub
'retablir la couleur de surlignage avec la couleur du fond normal
CoulSurLign = RichTextBox1.BackColor  '
R = CStr(CoulSurLign And &HFF&) 'recuperation de la composante rouge
G = CStr((CoulSurLign And &HFF00&) / 2 ^ 8) '.... vert
B = CStr((CoulSurLign And &HFF0000) / 2 ^ 16) '.... bleu
Rechercher
End Sub
Public Sub Rechercher()
  Dim Fin As Long, PosTrouver As Long
  RichTextBox1.SelStart = 0: RichTextBox1.SelLength = 64000 '<== optenir le nombre de caractére
  Fin = RichTextBox1.SelLength: RichTextBox1.SelLength = 0
  PosTrouver = 0
  'boucle de recherche du mot
  Do While PosTrouver <= Fin
   PosTrouver = RichTextBox1.Find(MotRechercher, PosTrouver, , rtfWholeWord)
   If PosTrouver <> -1 Then 'mot trouvé
    'colorisation du fond du mot trouvé
    SurligneSelection RichTextBox1
    'pour la suite de la recherche
    PosTrouver = PosTrouver + Len(MotRechercher)
    Else
    'à atteint la fin du document sans (re)trouvé le mot
    Exit Do
   End If
   DoEvents
  Loop
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
 
Dim CoulInvEncre As OLE_COLOR
Dim Rr As Long, Gg As Long, Bb As Long
'recuperation de la couleur encre de la selection
CoulInvEncre = TextRichBox.SelColor 'recuperation de la couleur à inverser
'inverse la couleur
Rr = 255 - CoulInvEncre And &HFF& 'Inverse la composante rouge
Gg = 255 - (CoulInvEncre And &HFF00&) / 2 ^ 8 '.... verte
Bb = 255 - (CoulInvEncre And &HFF0000) / 2 ^ 16 '.... bleu
'convertion en long acceptable pour la propriété du RichTextBox
CoulInvEncre = RGB(Rr, Gg, Bb)
'attribution
TextRichBox.SelColor = CoulInvEncre
 
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
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

Apres le run Projet, tu colles un texte dedans (Btn droit dans le RichtextBox) puis tu click sur le premier bouton"Rechercher dans tout le document", tu entres le mot à rechercher, à la suite du Ok les mots retrouvés seront de couleur encre inversé sur fond bleu, un click sur le bouton "Supprimer le sur-lignage" rétabli les couleurs d'avant la recherche.

[ProgElecT]

parce que a ce que j ai vu y a un leger defaut a ton code , si je relance une autre recherche , plus moyen d enlever les anciens surlignages donc dans le cas ou je doit cherche x mot , ca coince
sauf a refaire les recherches dans l ordre inverse et d enlever a chaque fois la selection mais alors ca bug cote couleur du texte ...

Modification et/ou ajout, signalé par des ligne commentaires ‘**************
Dans les déclarations global du Form, ajouter

Code :

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

Dim UndoRichText As String

Ajouter le nouvel évènement de RichTextBox1

Code :

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

1
2
3
4
5
6
7
8
9
10
11
'**************************************************************
Private Sub RichTextBox1_Click()
If UndoRichText <> "" Then
 Dim Poscurs As Long
 Poscurs = RichTextBox1.SelStart
 RichTextBox1.TextRTF = UndoRichText
 UndoRichText = ""
 RichTextBox1.SelStart = Poscurs
End If
End Sub
'**************************************************************

Remplacer Command1_Click, Command2_Click() et Rechercher() avec çà

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
Private Sub Command1_Click()
'**************************************************************
If UndoRichText <> "" Then RichTextBox1.TextRTF = UndoRichText
UndoRichText = ""
'**************************************************************
MotRechercher = InputBox("Mot à rechercher ?", "Rechercher dans tout le document")
If Trim(MotRechercher) = "" Then Exit Sub
MotRechercher = Trim(MotRechercher)
'&HFF0000 =16711680 = bleu
CoulSurLign = &HFF0000 '***** ICI tu peux choisir une autre couleur de sur-lignage *********
R = CStr(CoulSurLign And &HFF&) 'recuperation de la composante rouge
G = CStr((CoulSurLign And &HFF00&) / 2 ^ 8) '.... vert
B = CStr((CoulSurLign And &HFF0000) / 2 ^ 16) '.... bleu
Rechercher
End Sub
Private Sub Command2_Click()
'If MotRechercher = "" Then Exit Sub
''retablir la couleur de surlignage avec la couleur du fond normal
'CoulSurLign = RichTextBox1.BackColor  '
'R = CStr(CoulSurLign And &HFF&) 'recuperation de la composante rouge
'G = CStr((CoulSurLign And &HFF00&) / 2 ^ 8) '.... vert
'B = CStr((CoulSurLign And &HFF0000) / 2 ^ 16) '.... bleu
'Rechercher
If UndoRichText <> "" Then RichTextBox1.TextRTF = UndoRichText: UndoRichText = ""
End Sub
Public Sub Rechercher()
  Dim Fin As Long, PosTrouver As Long
'************************
Dim PrimPos As Long '****
PrimPos = -1 '***********
'************************
  RichTextBox1.SelStart = 0: RichTextBox1.SelLength = 64000 '<== optenir le nombre de caractére
  Fin = RichTextBox1.SelLength: RichTextBox1.SelLength = 0
  PosTrouver = 0
  'boucle de recherche du mot
  Do While PosTrouver <= Fin
   PosTrouver = RichTextBox1.Find(MotRechercher, PosTrouver, , rtfWholeWord)
   If PosTrouver <> -1 Then 'mot trouvé
    '**********************************************************
    If PrimPos = -1 Then
     '--------- Memorisation du contenu, formatage compris ---*
     UndoRichText = RichTextBox1.TextRTF
     '---- permetra de ce reposition sur le premier mot trouvé en fin de recherche
     PrimPos = PosTrouver
    End If
    '**********************************************************
    'colorisation du fond du mot trouvé
    SurligneSelection RichTextBox1
    'pour la suite de la recherche
    PosTrouver = PosTrouver + Len(MotRechercher)
    Else
    'à atteint la fin du document sans (re)trouvé le mot
    Exit Do
   End If
   DoEvents
  Loop
'****************************************************
If PrimPos <> -1 Then RichTextBox1.SelStart = PrimPos
'****************************************************
End Sub

Tu me dis si cela convient et/ou les modifications que tu y apportes, cela pour servir à la communauté.

[atc666]

aie c est toujous pas ca , mais je pense qu on s est mal compris

en fait je doit pouvoir faire une recherche sur plusieurs mots en meme temps

donc la j ai modifie le command1 comme suit :

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 Sub Command1_Click()
List1.Clear
'**************************************************************
If UndoRichText <> "" Then RichTextBox1.TextRTF = UndoRichText
UndoRichText = ""
'**************************************************************
MotRechercher = InputBox("Mot à rechercher ?", "Rechercher dans tout le document")
If Trim(MotRechercher) = "" Then Exit Sub
 
'&HFF0000 =16711680 = bleu
CoulSurLign = &HFF0000 '***** ICI tu peux choisir une autre couleur de sur-lignage *********
R = CStr(CoulSurLign And &HFF&) 'recuperation de la composante rouge
G = CStr((CoulSurLign And &HFF00&) / 2 ^ 8) '.... vert
B = CStr((CoulSurLign And &HFF0000) / 2 ^ 16) '.... bleu
 
'selection des mots a rechercher et enregistrement dans une listbox
az = InStr(1, MotRechercher, " ") ' recherche du premier mot
If az > 0 Then
List1.AddItem (Mid(MotRechercher, 1, az - 1))
Do While az <> 0 ' si plusieurs mot recherche des autres 
oldaz = az
az = InStr(az + 1, MotRechercher, " ")
If az = 0 Then List1.AddItem (Mid(MotRechercher, oldaz+1)): Exit Do
List1.AddItem (Mid(MotRechercher, oldaz+1, az - oldaz))
 
Loop
Else
 
List1.AddItem (Mid(MotRechercher, 1))
End If
Stop
For az = 1 To List1.ListCount
MotRechercher = List1.List(az - 1)
 
Rechercher
Next az
End Sub

Mais ca ne surligne que le premier mot de ma liste

je regarde dans la matinee si je peut trouver ou ca coince et je t en dit plus

[atc666]

Bon la je pense que j ai fini par reussir a optenir ce que je voullait que mon code fasse :
vla le code , je m excuse mais il est pas commente la , je vais voir pour le faire et te filer une version commentee des que possible

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
Private Sub Command3_Click()
If slrichtext <> "" Then RichTextBox1.TextRTF = slrichtext
End Sub
Private Sub Command1_Click()
List1.Clear
'**************************************************************
If UndoRichText <> "" Then RichTextBox1.TextRTF = UndoRichText
UndoRichText = ""
'**************************************************************
MotRechercher = InputBox("Mot à rechercher ?", "Rechercher dans tout le document")
If Trim(MotRechercher) = "" Then Exit Sub
 
'&HFF0000 =16711680 = bleu
CoulSurLign = &HFF0000 '***** ICI tu peux choisir une autre couleur de sur-lignage *********
R = CStr(CoulSurLign And &HFF&) 'recuperation de la composante rouge
G = CStr((CoulSurLign And &HFF00&) / 2 ^ 8) '.... vert
B = CStr((CoulSurLign And &HFF0000) / 2 ^ 16) '.... bleu
 
 
az = InStr(1, MotRechercher, " ")
If az > 0 Then
List1.AddItem (Mid(MotRechercher, 1, az - 1))
Do While az <> 0
oldaz = az
az = InStr(az + 1, MotRechercher, " ")
If az = 0 Then List1.AddItem (Mid(MotRechercher, oldaz + 1)): Exit Do
List1.AddItem (Mid(MotRechercher, oldaz + 1, az - oldaz - 1))
 
Loop
Else
 
List1.AddItem (Mid(MotRechercher, 1))
End If
Stop
UndoRichText = RichTextBox1.TextRTF
For az = 1 To List1.ListCount
MotRechercher = List1.List(az - 1)
Stop
rechercher
 
Next az
slrichtext = RichTextBox1.TextRTF
End Sub
Private Sub Command2_Click()
'If MotRechercher = "" Then Exit Sub
''retablir la couleur de surlignage avec la couleur du fond normal
'CoulSurLign = RichTextBox1.BackColor  '
'R = CStr(CoulSurLign And &HFF&) 'recuperation de la composante rouge
'G = CStr((CoulSurLign And &HFF00&) / 2 ^ 8) '.... vert
'B = CStr((CoulSurLign And &HFF0000) / 2 ^ 16) '.... bleu
'Rechercher
If UndoRichText <> "" Then RichTextBox1.TextRTF = UndoRichText
End Sub
 
Public Sub rechercher()
Dim PosTrouver As Long
PosTrouver = 0
RichTextBox1.SelStart = 0
Stop
While PosTrouver <> -1
 
PosTrouver = RichTextBox1.Find(MotRechercher, PosTrouver, , rtfWholeWord)
If PosTrouver <> -1 Then
SurligneSelection RichTextBox1
PosTrouver = PosTrouver + Len(MotRechercher)
 
End If
Wend
DoEvents
End Sub

la partie qui fait le surlignage , je n ai pas "encore ose poser mes doigts dessus mais bon je verrai d ici peu si je peut l alleger un peu ou si tout est obligatoire dedans

(j avoue que mon code a souvent pour ne pas dire tjs l apparence d un bordel monumental mais bon ... )

bon un giga et un paquet de giga et des terra de pour toi et ta patience

[ProgElecT]

Pour la partie formatage, toutes les instructions de la sub SurligneSelection(TextRichBox As RichTextBox) sont indispensables, je ne vois pas ou tu pourrais réduire le code.

Ma petite dernière contribution
L’important est que ton programme fonctionne comme tu le veux, je te mets cette dernière version qui semble convenir à ton cahier des charges, elle est légèrement différente de celle que tu as choisis, tu en fais ce que tu veux bien sûr.

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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
Option Explicit
Dim R As Byte, G As Byte, B As Byte
Dim T As Long, U As Long, V As Long
Dim MotRechercher As String
Dim CoulSurLign As OLE_COLOR
Dim UndoRichText As String
Private Sub Form_Load()
Command1.Caption = "Rechercher dans tout le document": Command2.Caption = "Supprimer le sur-lignage"
Command1.Move 120, 90, 3705, 360
Command2.Move 3945, 90, 1965, 360
RichTextBox1.AutoVerbMenu = True
'&HFFFFFF = 16777215 = blanc
RichTextBox1.BackColor = &HFFFFFF 'choisir toutes couleurs non Système
RichTextBox1.TextRTF = ""
RichTextBox1.Move 90, 540, 8490, 4905
'puisque la couleur de sur-lignage ne change pas durant toute
'l'utilisation du programme, ne la definir qu'une fois dans cette Sub
'&HFF0000 =16711680 = bleu
CoulSurLign = &HFF0000 '***** ICI tu peux choisir une autre couleur de sur-lignage *********
R = CStr(CoulSurLign And &HFF&) 'recuperation de la composante rouge
G = CStr((CoulSurLign And &HFF00&) / 2 ^ 8) '.... vert
B = CStr((CoulSurLign And &HFF0000) / 2 ^ 16) '.... bleuMe.Height = 6135: Me.Width = 9045
End Sub
 
Private Sub RichTextBox1_Click()
'If UndoRichText <> "" Then
' Dim Poscurs As Long
' Poscurs = RichTextBox1.SelStart
' RichTextBox1.TextRTF = UndoRichText
' UndoRichText = ""
' RichTextBox1.SelStart = Poscurs
'End If
End Sub
Private Sub Command1_Click()
Dim MsG As String
'j'ai choisi le point virgule comme separateur, ce qui permet de faire rechercher eventuelement des mots
'composés, exemple: "cerf volant" "compte rendu" ......
'pour facilité la construction de l'information dans l'InputBox
MsG = "Mot(s) à rechercher ?" & vbCrLf _
    & "Si vous désirez plusieurs mots, separez-les par un point virgule." & vbCrLf _
    & "Exemple pour 1 mot: texte" & vbCrLf _
    & "Exemple pour 5 mots: Le;La;Les;tabeau;texte"
MotRechercher = InputBox(MsG, "Rechercher dans tout le document")
MotRechercher = Trim(MotRechercher)
If MotRechercher = "" Then Exit Sub
Rechercher
End Sub
Private Sub Command2_Click()
If UndoRichText <> "" Then RichTextBox1.TextRTF = UndoRichText: UndoRichText = ""
End Sub
 
Public Sub Rechercher()
Dim Fin As Long, PosTrouver As Long
Dim PrimPos As Long
Dim TblMots() As String ' variable tableau des mots a rechercher
Dim CmptBcl As Integer 'pour boucle du Nbr de mots a retrouver
'verifier si il y a plusieurs mots a rechercher
If InStr(MotRechercher, ";") Then
 'a priori il y a plus d'un mot a rechercher puisque le point virgule a été utilisé
 TblMots = Split(MotRechercher, ";") '<== ici il a été choisis arbitrairement le point virgule comme separateur
 Else
'il n'y a qu'un mot a rechercher, MotRechercher n'étant pas egal a ""
 ReDim TblMots(0)
 TblMots(0) = MotRechercher
End If
RichTextBox1.SelStart = 0: RichTextBox1.SelLength = 64000 '<== optenir le nombre de caractéres
Fin = RichTextBox1.SelLength: RichTextBox1.SelLength = 0
PrimPos = -1
 
For CmptBcl = 0 To UBound(TblMots)
 'boucle de recherche du/des mot(s)
  PosTrouver = 0: MotRechercher = TblMots(CmptBcl)
 
  'boucle de recherche avec l'un des mots
  Do While PosTrouver <= Fin
   PosTrouver = RichTextBox1.Find(MotRechercher, PosTrouver, , rtfWholeWord)
   If PosTrouver <> -1 Then 'au moins 1 mot trouvé
    If PrimPos = -1 Then
     '--------- Memorisation du contenu, formatage compris ---*
     UndoRichText = RichTextBox1.TextRTF
     '---- permetra de ce reposition sur le premier mot trouvé en fin de recherche
     PrimPos = PosTrouver
    End If
    'colorisation du fond du mot trouvé
    SurligneSelection RichTextBox1
    'pour la suite de la recherche
    PosTrouver = PosTrouver + Len(MotRechercher)
    Else
    'à atteint la fin du document sans (re)trouvé le mot ou l'un des mots
    Exit Do
   End If
   DoEvents
  Loop
 
Next CmptBcl
'****************************************************
If PrimPos <> -1 Then RichTextBox1.SelStart = PrimPos
'****************************************************
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
 
Dim CoulInvEncre As OLE_COLOR
Dim Rr As Long, Gg As Long, Bb As Long
'recuperation de la couleur encre de la selection
CoulInvEncre = TextRichBox.SelColor 'recuperation de la couleur à inverser
'inverse la couleur
Rr = 255 - CoulInvEncre And &HFF& 'Inverse la composante rouge
Gg = 255 - (CoulInvEncre And &HFF00&) / 2 ^ 8 '.... verte
Bb = 255 - (CoulInvEncre And &HFF0000) / 2 ^ 16 '.... bleu
'convertion en long acceptable pour la propriété du RichTextBox
CoulInvEncre = RGB(Rr, Gg, Bb)
'attribution
TextRichBox.SelColor = CoulInvEncre
 
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
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

Bonne continuation …..