Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

  1. #1
    Rédacteur/Modérateur
    Avatar de ProgElecT
    Homme Profil pro
    Retraité
    Inscrit en
    décembre 2004
    Messages
    4 896
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 63
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Retraité
    Secteur : Communication - Médias

    Informations forums :
    Inscription : décembre 2004
    Messages : 4 896
    Points : 11 020
    Points
    11 020

    Par défaut RichTextBox et surlignage

    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.
    ProgElecT
    Soyez sympa, pensez -y
    Balises[CODE]...[/CODE]
    Balises[CODE=NomDuLangage]...[/CODE] quand vous mettez du code d'un autre langage que celui du forum ou vous postez.
    Le bouton en fin de discussion, quand vous avez obtenu l'aide attendue.
    ......... et pourquoi pas, pour remercier, un pour celui/ceux qui vous ont dépannés.

  2. #2
    Rédacteur
    Avatar de DarkVader
    Homme Profil pro
    Développeur informatique
    Inscrit en
    mai 2002
    Messages
    2 124
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : Développeur informatique
    Secteur : High Tech - Éditeur de logiciels

    Informations forums :
    Inscription : mai 2002
    Messages : 2 124
    Points : 2 978
    Points
    2 978

    Par défaut

    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.

  3. #3
    Rédacteur/Modérateur
    Avatar de ProgElecT
    Homme Profil pro
    Retraité
    Inscrit en
    décembre 2004
    Messages
    4 896
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 63
    Localisation : France, Haute Savoie (Rhône Alpes)

    Informations professionnelles :
    Activité : Retraité
    Secteur : Communication - Médias

    Informations forums :
    Inscription : décembre 2004
    Messages : 4 896
    Points : 11 020
    Points
    11 020

    Par défaut



    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é.
    ProgElecT
    Soyez sympa, pensez -y
    Balises[CODE]...[/CODE]
    Balises[CODE=NomDuLangage]...[/CODE] quand vous mettez du code d'un autre langage que celui du forum ou vous postez.
    Le bouton en fin de discussion, quand vous avez obtenu l'aide attendue.
    ......... et pourquoi pas, pour remercier, un pour celui/ceux qui vous ont dépannés.

  4. #4
    Rédacteur
    Avatar de DarkVader
    Homme Profil pro
    Développeur informatique
    Inscrit en
    mai 2002
    Messages
    2 124
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Localisation : France, Paris (Île de France)

    Informations professionnelles :
    Activité : Développeur informatique
    Secteur : High Tech - Éditeur de logiciels

    Informations forums :
    Inscription : mai 2002
    Messages : 2 124
    Points : 2 978
    Points
    2 978

    Par défaut

    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

Discussions similaires

  1. RichTextBox surlignage ligne courante
    Par ppphil dans le forum Contribuez
    Réponses: 2
    Dernier message: 19/09/2008, 12h22
  2. [C#] Surlignage d'un élement d'une ListView
    Par tontonplaisir dans le forum Windows Forms
    Réponses: 9
    Dernier message: 08/09/2004, 15h35
  3. [VB.NET] Pb avec le soulignement dans un RichTextBox
    Par Ludog35 dans le forum Windows Forms
    Réponses: 3
    Dernier message: 09/06/2004, 18h59
  4. [VB6] Ecrire à un endroit précis d'un richtextbox
    Par STG dans le forum VB 6 et antérieur
    Réponses: 8
    Dernier message: 26/11/2002, 14h35
  5. [VB6] [RichTextBox] Aller en bas
    Par fea dans le forum VB 6 et antérieur
    Réponses: 6
    Dernier message: 22/10/2002, 11h24

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo