Добавить цветную строку в Richedit

alexan0308 · #1 01.05.2013, 20:45

Часто встречается вопросы про добавление форматированной строки в Richedit. Ответ есть, через управление SelAttributes, но сам код при этом становится не очень наглядным. Есть компонент, но он платный. Когда мне тоже понадобилось, покорпел, наскреб процедуру, которая решает задачу, хоть и не полностью. Короче вот:

Код:

uses StrUtils;

Код:

var
  Form1: TForm1; RichEdit_text : string;

RichEdit_text - добавляемая строка - сделана глобальной, чтобы потом легче было использовать процедуру в потоке.

Вот процедура

Код:

procedure RichEdit_add_text;
// процедура  RichEdit_add_text добавляет текстовую строку RichEdit_text с тегами в RichEdit1
 
function HtmlColorToTColor(Color: string):TColor ;
const DelphiColorConst = 'clblack, clmaroon, clgreen, clolive, clnavy, clpurple, clteal, clgray, clsilver, clred, cllime, clyellow, clblue, clfuchsia, claqua, clwhite';
var
  rColor: TColor;
begin
try
  if ansipos(AnsiLowerCase(Color),DelphiColorConst)>0 then begin result := StringToColor('CL' + Color);  exit; end;
  delete(Color,1,1);
  if (length(color) >= 6) then
  begin
    {незабудьте, что TColor это bgr, а не rgb: поэтому необходимо изменить порядок}
    color := '$00' + copy(color,5,2) + copy(color,3,2) + copy(color,1,2);
    rColor := StrToInt(color);
  end;
  result := rColor;
except
   result :=  $000000;
end;
end;
 
function before_tag_symbol_delete(sssr:string; n:integer):string;
var  k : integer; res : string;
begin
     k:=0;  res:='';
      while k<n do
        begin
            inc(k);
            if sssr[k] = '<' then while sssr[k] <> '>' do begin inc(k); end;
            if sssr[k] = '>' then continue;
            res:=res +  sssr[k];
        end;
   before_tag_symbol_delete:=res + copy(sssr,n, length(sssr)- n + 1);
end;
 
 
var st, zvet, sssr, raspad_sssr,  rf : string;
raspad_count, k, mm, k_beg, k_end, k_end_color, globbegin, tag_color, tag_bf, tag_italic, tag_, Line : integer;
color : Tcolor;
pole_zvetov : string; arbeiten: integer;
 
begin
   sssr :=  RichEdit_text;
      st:=''; k:=1;
    while k<=length(sssr) do
      begin
          if sssr[k]<>'<' then begin  st:=st+sssr[k]; end
                  else while sssr[k]<>'>' do inc(k);
                  inc(k);
      end;
       Line:=  Form1.Richedit1.Lines.Count;
       st:= StringReplace(st, '&lt;', '<', [rfReplaceAll, rfIgnoreCase]);
       st:= StringReplace(st, '&gt;', '>', [rfReplaceAll, rfIgnoreCase]);
      Form1.Richedit1.Lines.Add(st);
 
       sssr:= StringReplace(RichEdit_text, '&lt;', '!', [rfReplaceAll, rfIgnoreCase]);
       sssr:= StringReplace(sssr, '&gt;', '!', [rfReplaceAll, rfIgnoreCase]);
       sssr:= StringReplace(sssr, '< ', '<', [rfReplaceAll, rfIgnoreCase]);
       sssr:= StringReplace(sssr, ' >', '>', [rfReplaceAll, rfIgnoreCase]);
        globbegin:= SendMessage(Form1.RichEdit1.Handle, EM_LINEINDEX, Line, 0);
         raspad_sssr:=sssr;
 
            arbeiten:=0;
            tag_:= ansipos('</', raspad_sssr);  // ищем ближайший закрывающий тег
            if tag_>0 then
                          if raspad_sssr[tag_+ 2] = 'f' then  arbeiten:=1    // </font>
                      else
                          if raspad_sssr[tag_+ 2] = 'b' then  arbeiten:=2    // </b>
                      else
                          if raspad_sssr[tag_+ 2] = 'i' then  arbeiten:=3;   //  </i>
 
  while arbeiten >0 do begin
 
   case arbeiten of
 
    1:    BEGIN
             k_end_color:=ansipos('<font color=',raspad_sssr);  rf:= before_tag_symbol_delete(raspad_sssr, k_end_color);
      k_beg:=ansipos('<font color=',rf);
      mm:=posex('>',rf, k_beg);
      k_end_color:=ansipos('</font>',rf);
 
      zvet:='CL' + copy(rf, k_beg+7+5, mm-k_beg-7-5);
 
      zvet:=copy(rf, k_beg+7+5, mm-k_beg-7-5);
 
      k_end:=k_end_color-(mm-k_beg)-2;
 
       Form1.Richedit1.SelStart := globbegin + k_beg - 1;
       Form1.Richedit1.SelLength:=  k_end-k_beg+1;
       Form1.Richedit1.SelAttributes.Color :=  HtmlColorToTColor(zvet);
 
 
      k_beg:=ansipos('<font color=',raspad_sssr);
      mm:=posex('>',raspad_sssr, k_beg);
      k_end_color:=ansipos('</font>',raspad_sssr);
      k_end:=k_end_color-(mm-k_beg)-2;
 
             delete(raspad_sssr, k_end_color, 7);
             delete(raspad_sssr, k_beg, length(zvet)+13);
      END;
 
    2:    BEGIN
          k_end_color:=ansipos('<b>',raspad_sssr);  rf:= before_tag_symbol_delete(raspad_sssr, k_end_color);
      k_beg:=ansipos('<b>',rf);
      mm:=posex('>',rf, k_beg);
      k_end_color:=ansipos('</b>',rf);
      k_end:=k_end_color-(mm-k_beg)-2;
 
       Form1.Richedit1.SelStart := globbegin + k_beg - 1;
       Form1.Richedit1.SelLength:=  k_end-k_beg+1;
            Form1.RichEdit1.SelAttributes.Style :=Form1.RichEdit1.SelAttributes.Style + [fsBold];
 
      k_beg:=ansipos('<b>',raspad_sssr);
      mm:=posex('>',raspad_sssr, k_beg);
      k_end_color:=ansipos('</b>',raspad_sssr);
      k_end:=k_end_color-(mm-k_beg)-2;
             delete(raspad_sssr, k_end_color, 4);
             delete(raspad_sssr, k_beg, 3);
   END;
 
    3:    BEGIN
                       k_end_color:=ansipos('<i>',raspad_sssr);  rf:= before_tag_symbol_delete(raspad_sssr, k_end_color);
      k_beg:=ansipos('<i>',rf);
      mm:=posex('>',rf, k_beg);
      k_end_color:=ansipos('</i>',rf);
      k_end:=k_end_color-(mm-k_beg)-2;
 
       Form1.Richedit1.SelStart := globbegin + k_beg - 1;
       Form1.Richedit1.SelLength:=  k_end-k_beg+1;
         Form1.RichEdit1.SelAttributes.Style :=Form1.RichEdit1.SelAttributes.Style + [fsItalic];
 
      k_beg:=ansipos('<i>',raspad_sssr);
      mm:=posex('>',raspad_sssr, k_beg);
      k_end_color:=ansipos('</i>',raspad_sssr);
      k_end:=k_end_color-(mm-k_beg)-2;
             delete(raspad_sssr, k_end_color, 4);
             delete(raspad_sssr, k_beg, 3);
   END;
 
   end;
            arbeiten:=0;
            tag_:= ansipos('</', raspad_sssr);  // ищем ближайший закрывающий тег
            if tag_>0 then
                          if raspad_sssr[tag_+ 2] = 'f' then  arbeiten:=1    // </font>
                      else
                          if raspad_sssr[tag_+ 2] = 'b' then  arbeiten:=2    // </b>
                      else
                          if raspad_sssr[tag_+ 2] = 'i' then  arbeiten:=3;   //  </i>
  end;
 
end;

Примеры использования:

Код:

procedure TForm1.Button1Click(Sender: TObject);
begin
      RichEdit_text:=  'Обычный текст';   RichEdit_add_text;
      RichEdit_text:=  'Текст с<font color=red><b><i>жирным, курсивным и красным</i></b></font>словом'; RichEdit_add_text;
      RichEdit_text:=  'Текст с<i><b><font color=#ffd700>золотистым, курсивным и жирным</font></b></i>словом'; RichEdit_add_text;
      RichEdit_text:=  'Текст с<font color=#4B0082><i>курсивным и цвета индиго</i></font>словом'; RichEdit_add_text;
      RichEdit_text:=  'Текст с<b><font color=Fuchsia>бирюзовым и жирным</font></b>словом'; RichEdit_add_text;
      RichEdit_text:=  'Доказать, что <font color=blue><b><i>c&gt;d</i></b></font> Задать...'; RichEdit_add_text;
      RichEdit_text:=  'Доказать, что <font color=#4B0082><b><i>a&lt;b</i></b></font> Найти...'; RichEdit_add_text;
      RichEdit_text:=  'Все вместе<i>курсивом</i>потом<b>жирным</b>потом<font color=green>зеленым</font>снова<b>жирным</b>опять<i>курсивом</i>еще<font color=red>красным</font>и обычным';
      RichEdit_add_text;
      RichEdit_text:=  'Опять обычный текст';   RichEdit_add_text;
end;

Есть плюсик - при сохранении отображаемого текста в html.
Буду рад отзывам...
Вложенность тегов реализована.
Добавлена поддержка html цветов. Разрешено указывать имена системных цветов в Delphi без приставки CL
Понятно, что нужно строго следить за вложенностью тегов, иначе результат непредсказуем. Знаки '<', '>' писать через соответствующие html-теги.

DrGeorg · #2 02.05.2013, 04:30

Что значит:

Цитата:

Сообщение от alexan0308

Ответ есть, через управление SelAttributes, но сам код при этом становится не очень наглядным.

Если надо добавить строку, то я делаю так:

Код:

RichEdit1.Lines.Add('Это наш текст');
RichEdit1.SelAttributes.Color:=clRead;
RichEdit1.SelText('Это наш текст');
RichEdit1.Lines.Delete(1);
RichEdit1.Lines.Add('');

Если какое-то слово, то так-же выделяете слово и применяете к нему атрибут Color. Только надо будет к каждому слову его применить...
Не знаю как другие свойства - не пробовал, но думаю так-же...

alexan0308 · #3 02.05.2013, 09:40

[OFF]admin, на панели инструментов нету кнопки для кода Delphi. [/OFF]

alexan0308 · #4 02.05.2013, 09:45

Цитата:

Сообщение от DrGeorg

Если надо добавить строку, то я делаю так:

Код:

RichEdit1.Lines.Add('Это наш текст');
RichEdit1.SelAttributes.Color:=clRead;
RichEdit1.SelText('Это наш текст');
RichEdit1.Lines.Delete(1);
RichEdit1.Lines.Add('');

Не работает, но мысль понятна. Тут действительно выигрыша не видно. Более сложный случай -

Код:

procedure TForm1.BitBtn1Click(Sender: TObject);
begin
RichEdit1.SelAttributes.Color:=clRed;
RichEdit1.SelText:='Это красный текст';
RichEdit1.SelAttributes.Color:=clblack;
Richedit1.SelAttributes.Style:=[fsBold];
RichEdit1.SelText:='Это жирный текст';
Richedit1.SelAttributes.Style:=Richedit1.SelAttributes.Style - [fsBold];
RichEdit1.SelAttributes.Style:=[fsItalic];
RichEdit1.SelText:='Это наклонный текст';
Richedit1.SelAttributes.Style:=Richedit1.SelAttributes.Style - [fsItalic];
RichEdit1.Lines.Add('');
end;

У меня будет выглядеть как

Код:

procedure TForm1.BitBtn2Click(Sender: TObject);
begin
  RichEdit_text:=  '<font color=red>Это красный текст</font>'   +
                   '<b>Это жирный текст</b>' +
                   '<i>Это наклонный текст</i>';
  RichEdit_add_text;
end;

Другое дело, мою процедуру легко использовать внутри потока. Как ваш код переделать под поток, в случае добавлении поочередно нескольких строк? даже не представляется возможным...

NumLock · #5 02.05.2013, 09:55

к чему этот огород в 1-ом сообщении? чем традиционный способ не угодил? и какая проблема с потоками? все-равно в Synchronize добавлять.

alexan0308 · #6 02.05.2013, 10:05

Цитата:

Сообщение от NumLock

и какая проблема с потоками? все-равно в Synchronize добавлять.

Покажите, как вы это сделаете в Delphi 7?

NumLock · #7 02.05.2013, 11:00

Код:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls;

type
  TRichEditThread = class(TThread)
  private
    FRichEdit: TRichEdit;
    FNum: Integer;
    FColor: TColor;
    procedure AddToRichEdit;
  protected
    procedure Execute; override;
  public
    constructor Create(ARichEdit: TRichEdit; ANum: Integer; AColor: TColor);
  end;

  TForm1 = class(TForm)
    RichEdit1: TRichEdit;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TRichEditThread }

procedure TRichEditThread.AddToRichEdit;
begin
  FRichEdit.SelAttributes.Color:=FColor;
  FRichEdit.SelText:=' TRichEditThread = '+IntToStr(FNum)+' ';
end;

constructor TRichEditThread.Create(ARichEdit: TRichEdit; ANum: Integer; AColor: TColor);
begin
  inherited Create(True);
  FreeOnTerminate:=True;
  FRichEdit:=ARichEdit;
  FNum:=ANum;
  FColor:=AColor;
  Resume;
end;

procedure TRichEditThread.Execute;
begin
  while True do
  begin
    Sleep(100+Random(400));
    Synchronize(AddToRichEdit);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  TRichEditThread.Create(RichEdit1, 1, clRed);
  TRichEditThread.Create(RichEdit1, 2, clGreen);
  TRichEditThread.Create(RichEdit1, 3, clBlue);
  TRichEditThread.Create(RichEdit1, 4, clYellow);
  TRichEditThread.Create(RichEdit1, 5, clLime);
  TRichEditThread.Create(RichEdit1, 6, clFuchsia);
end;

end.

alexan0308 · #8 02.05.2013, 11:31

Это все хорошо, когда добавляется однородный текст. А если нужно добавлять в потоке разные строки? Например:
...
1. проверка орфографии
Ошибка в слове теливизор.
Правильно - телевизор
2. проверка пунктуации
После между прочим должна стоять запятая!
...

NumLock · #9 02.05.2013, 13:32

и в чем проблема? надо - добавляй разнородный.

alexan0308 · #10 02.05.2013, 13:44

Цитата:

Сообщение от NumLock

и в чем проблема? надо - добавляй разнородный.

Голову зашкалит от постоянного изменения атрибутов. В общем, добавил я вложенность тегов и поддержку html цветов. Разрешено указывать имена системных цветов в Delphi без приставки CL

NumLock · #11 02.05.2013, 14:12

ну не зашкаливает же:

Код:

procedure TRichEditThread.AddText(Text: String; Color: TColor = clBlack; Style: TFontStyles = []);
begin
  FRichEdit.SelAttributes.Color:=Color;
  FRichEdit.SelAttributes.Style:=Style;
  FRichEdit.SelText:=Text;
end;

procedure TRichEditThread.AddToRichEdit;
begin
  AddText(' TRichEditThread = '+IntToStr(FNum)+' ', FColor, []);
  AddText('procedure ', clBlue, [fsBold]);
  AddText('TRichEditThread.AddToRichEdit ', clLime, []);
  AddText('begin'#13#10, clBlack);
  AddText('end');
end;

http://www.delphisources.ru/forum/sh...ad.php?t=18236
http://www.delphisources.ru/forum/sh...ad.php?t=18196

alexan0308 · #12 02.05.2013, 14:23

Цитата:

Сообщение от NumLock

ну не зашкаливает же:

Да, но ты все равно добавил однородные строки. Ты добавь мой пример

Цитата:

Сообщение от alexan0308

...
1. проверка орфографии
Ошибка в слове теливизор.
Правильно - телевизор
2. проверка пунктуации
После между прочим должна стоять запятая!
...

NumLock · #13 02.05.2013, 14:46

твой пример на много проще просто грузить из .rtf файла или ресурса. когда же требуется добавлять динамический текст, как например в CodeShow и Spamka, городить строки с тэгами нет смысла.

alexan0308 · #14 02.05.2013, 15:14

Текст у меня динамический. Выполняется более десятка разных по смыслу действий, по проверке документов.
...
1. проверка орфографии
// обработка
Ошибка в слове теливизор.
Правильно - телевизор
2. проверка пунктуации
// обработка
После между прочим должна стоять запятая!
3. проверка полей
// обработка
Левое поле 30 мм - в норме.
Правое поле 15 мм - должно быть 10 мм.
4. проверка стиля шрифта
// обработка
Запрещено использовать курсив: Это явление называется интерференцией.
Жирным выделять только заголовки: Это явление называется дифракцией.
...
Без тегов я утону в коде.

NumLock · #15 02.05.2013, 15:29

тогда нужно полностью менять подход к задаче.

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	Соглашения	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Конфиденциальность Соглашение пользователя Правила обработки cookie	О сайте Donate Контакты