I would like to ask about a problem where I cannot change the font name and color of the content in a control under Laza

[wsy211]

I would like to ask about a problem where I cannot change the font name and color of the content in a control under Lazarus.

This sample code demonstrates the function that when Button1Click is clicked, a string text is added to RichViewEdit1, divided into two paragraphs. Then when CheckBox1Click is clicked, the font name and color of the text in each paragraph of RichViewEdit1 will change according to the conditions. This code can normally change the text color and font name in Delphi, but now it cannot change the text color and font name in Lazarus. Could the group owner please take a look and see where the problem lies?
thank you！！
RichView23.0.1 lazarUS 3.4 fpc3.2.2

Look at the effect pictures.

[wsy211]

The effect drawing to be achieved.

[wsy211]

Images cannot be uploaded directly; they can only be compressed and uploaded.

[wsy211]

The forum doesn't allow me to upload anything anymore. I'll paste the demonstration code.

Code: Select all

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, RVStyle,
  RVEdit,
  RVTable,
  RVTypes,
  CRVData,
  RichView,
  LazUTF8;

type

  TTextColorPair = record
    AText: TRVUnicodeString;
    AColor: TColor;
    Afontname: TRVUnicodeString;
  end;

  TTextColorPairs = array of TTextColorPair;



type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    CheckBox1: TCheckBox;
    Label1: TLabel;
    Label2: TLabel;
    RichViewEdit1: TRichViewEdit;
    RVStyle1: TRVStyle;
    procedure Button1Click(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    procedure ColorLines(rv: TCustomRichView;
      const TextColorPairs: TTextColorPairs);
    procedure fontnameLines(rv: TCustomRichView;
      const TextColorPairs: TTextColorPairs);


    function GetColorForText(const AText: TRVUnicodeString;
      const TextColorPairs: TTextColorPairs): TColor;
    function GetStyleNoWithColor(rvs: TRVStyle; StyleNo: integer;
      AColor: TColor): integer;

    function GetText_fontname(const AText: TRVUnicodeString;
      const TextColorPairs: TTextColorPairs): TRVUnicodeString;
    function GetStyleNoWithfontname(rvs: TRVStyle; AStyleNo: integer;
      Afontname: TRVUnicodeString): integer;
  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
begin
  RichViewEdit1.SetFocus;
  RichViewEdit1.InsertText(
    'A：我是中国人，现在正在用RichViewEdit演示改变整个段落文字的字体名称和文字颜色。'
    +
    #13#10 + 'B：但是没改变成功！差在哪？');

  RichViewEdit1.Format;
end;



procedure TForm1.CheckBox1Click(Sender: TObject);
var
  ColorRules: TTextColorPairs;
begin
  if CheckBox1.Checked = True then
  begin
    RichViewEdit1.BeginUpdate;
    // rve.EndUpdate;
    begin
      SetLength(ColorRules, 4);


      ColorRules[0].AText := 'A：';
      ColorRules[0].AColor := clRed;
      ColorRules[0].Afontname := '黑体';

      ColorRules[1].AText := 'B：';
      ColorRules[1].AColor := clNavy;
      ColorRules[1].Afontname := '楷体';

      ColorLines(RichViewEdit1, ColorRules);
      fontnameLines(RichViewEdit1, ColorRules);

      RichViewEdit1.Invalidate;
    end;
    RichViewEdit1.EndUpdate;
  end
  else
  begin
    RichViewEdit1.BeginUpdate;
    begin
      SetLength(ColorRules, 4);

      ColorRules[0].AText := 'A：';
      ColorRules[0].AColor := clBlack;

      ColorRules[1].AText := 'B：';
      ColorRules[1].AColor := clBlack;
      ColorLines(RichViewEdit1, ColorRules);

      RichViewEdit1.Invalidate;
    end;
    RichViewEdit1.EndUpdate;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
begin
  // 确保所有文本样式支持 Unicode
  for i := 0 to RVStyle1.TextStyles.Count - 1 do
  begin
    RVStyle1.TextStyles[i].Unicode := True;
  end;

  // 可选：如果 TextStyles 为空，添加一个默认样式
  if RVStyle1.TextStyles.Count = 0 then
  begin
    with RVStyle1.TextStyles.Add do
    begin
      StyleName := 'Normal';
      FontName := '宋体';
      Size := 15;
      Color := clBlack;
    end;
  end;

  // 设置 RichViewEdit  RTFReadProperties 以更好地处理 Unicode 文本 [8](@ref)
  RichViewEdit1.RTFReadProperties.ParaStyleMode := rvrsAddIfNeeded;
  RichViewEdit1.RTFReadProperties.TextStyleMode := rvrsAddIfNeeded;
  RichViewEdit1.RTFReadProperties.UnicodeMode := rvruOnlyUnicode;
end;


// Changes colors of text in rv basing on rules specified TextColorPairs
procedure TForm1.ColorLines(rv: TCustomRichView;
  const TextColorPairs: TTextColorPairs);
var
  i: integer;
  AColor: TColor;
  // fontname : TRVUnicodeString;
begin
  AColor := clNone;
  for i := 0 to rv.ItemCount - 1 do
  begin
    if rv.IsParaStart(i) then
      if rv.GetItemStyle(i) >= 0 then
        AColor := GetColorForText(rv.GetItemTextW(i), TextColorPairs)
      else
        AColor := clNone;
    if (AColor <> clNone) and (rv.GetItemStyle(i) >= 0) then
      rv.GetItem(i).StyleNo :=
        GetStyleNoWithColor(rv.Style, rv.GetItemStyle(i), AColor);
  end;
end;

// Changes colors of text in rv basing on rules specified TextColorPairs
procedure TForm1.fontnameLines(rv: TCustomRichView;
  const TextColorPairs: TTextColorPairs);
var
  i: integer;
  // AColor: TColor;
  fontname: TRVUnicodeString;
begin
  fontname := '';
  for i := 0 to rv.ItemCount - 1 do
  begin
    if rv.IsParaStart(i) then
      if rv.GetItemStyle(i) >= 0 then
        fontname := GetText_fontname(rv.GetItemTextW(i), TextColorPairs)
      else
        fontname := '';
    if (fontname <> '') and (rv.GetItemStyle(i) >= 0) then
      rv.GetItem(i).StyleNo :=
        GetStyleNoWithfontname(rv.Style, rv.GetItemStyle(i), fontname);
  end;
end;

// Returns color for Text from the rules listed in TextColorPairs
function TForm1.GetColorForText(const AText: TRVUnicodeString;
  const TextColorPairs: TTextColorPairs): TColor;
var
  i: integer;
begin
  Result := clNone;
  for i := Low(TextColorPairs) to High(TextColorPairs) do
    if utf8Copy(AText, 1, utf8Length(TextColorPairs[i].AText)) =
      TextColorPairs[i].AText then
    begin
      Result := TextColorPairs[i].AColor;
      Exit;
    end;
end;

// Returns index of in rvs.TextStyles of the style having all properties of
// rvs.TextStyles[StyleNo], but the specified color.
// If it does not exist, it is created
function TForm1.GetStyleNoWithColor(rvs: TRVStyle; StyleNo: integer;
  AColor: TColor): integer;
var
  TextStyle: TFontInfo;
begin
  if rvs.TextStyles[StyleNo].Color = AColor then
  begin
    Result := StyleNo;
    Exit;
  end;
  TextStyle := TFontInfo.Create(nil);
  TextStyle.Assign(rvs.TextStyles[StyleNo]);
  TextStyle.Color := AColor;

  // rv.Style.TextStyles[rv.CurTextStyleNo].FontName

  Result := rvs.FindTextStyle(TextStyle);
  TextStyle.Free;
end;



// Returns color for Text from the rules listed in TextColorPairs
function TForm1.GetText_fontname(const AText: TRVUnicodeString;
  const TextColorPairs: TTextColorPairs): TRVUnicodeString;
var
  i: integer;
begin
  Result := '';
  for i := Low(TextColorPairs) to High(TextColorPairs) do
    if utf8Copy(AText, 1, utf8Length(TextColorPairs[i].AText)) =
      TextColorPairs[i].AText then
    begin
      Result := TextColorPairs[i].Afontname;
      Exit;
    end;
end;

// Returns index of in rvs.TextStyles of the style having all properties of
// rvs.TextStyles[StyleNo], but the specified color.
// If it does not exist, it is created
function TForm1.GetStyleNoWithfontname(rvs: TRVStyle; AStyleNo: integer;
  Afontname: TRVUnicodeString): integer;
var
  ATextStyle: TFontInfo;
begin
  if rvs.TextStyles[AStyleNo].fontname = Afontname then
  begin
    Result := AStyleNo;
    Exit;
  end;
  ATextStyle := TFontInfo.Create(nil);
  ATextStyle.Assign(rvs.TextStyles[AStyleNo]);
  ATextStyle.fontname := Afontname;
  //rv.Style.TextStyles[rv.CurTextStyleNo].FontName
  Result := rvs.FindTextStyle(ATextStyle);
  ATextStyle.Free;
end;



end.       
Could you please take a look? Where's the problem?

[Sergey Tkachenko]

It looks like Lazarus assigns string literals to UnicodeString incorrectly.

My suggestion for changing your code.

1) Change the type of Afontname of TTextColorPair to TFontName.

Code: Select all

  TTextColorPair = record
    AText: TRVUnicodeString;
    AColor: TColor;
    Afontname: TFontName;
  end;                   

2) Use Utf8Decode to assign a string literal to TRVUnicodeString:

Code: Select all

      ColorRules[0].AText := Utf8Decode('A：');
      ColorRules[0].AColor := clRed;
      ColorRules[0].Afontname := '黑体';

      ColorRules[1].AText := Utf8Decode('B：');
      ColorRules[1].AColor := clNavy;
      ColorRules[1].Afontname := '楷体';       

3) When comparing TRVUnicodeStrings, do not use UTF-8 functions.
In GetColorForText and GetStyleNoWithColor change the condition checking to:

Code: Select all

    if Copy(AText, 1, Length(TextColorPairs[i].AText)) =
      TextColorPairs[i].AText then                      

Or, if you add RVStrFuncs to "uses", you can simply write:

Code: Select all

    if RVBeginsWithW(AText, TextColorPairs[i].AText) then

4) It's not critical, but it's better to change types of all fontname parameters, function results, and local variables to TFontName.
You will see, all warnings about string conversions will be gone.

I attached the modified unit.

PS: I made changes to the project attached to your first message.

[wsy211]

@Sergey Tkachenko It's indeed a coding issue, thank you

[wsy211]

@Sergey Tkachenko
Hello, I have another question. When I execute the code in cmbFontChange to change the font name of all the text in RichViewEdit1 at once, sometimes it works without any errors, but sometimes it doesn't work and throws the exception "Project project1 raised an exception class 'External: Unknown exception code 8'. In file 'laztracer.pas' at line 58: if (length (Msg) div (length(Msg) div 10000))=0 then". Why is this happening? How can I correctly use the code to change the font name of the text? Thank you!

Code: Select all

 

 cmbFont: TComboBox;    
 private

    IgnoreChanges: boolean;
    FontSize: integer;
    fontname: string;  

const
  TEXT_BOLD = 1;
  TEXT_ITALIC = 2;
  TEXT_UNDERLINE = 3;
  TEXT_APPLYFONTNAME = 4;
  TEXT_APPLYFONT = 5;
  TEXT_APPLYFONTSIZE = 6;
  TEXT_COLOR = 7;
  TEXT_BACKCOLOR = 8;
  // Parameters for ApplyParaStyleConversion
  PARA_ALIGNMENT = 1;
  PARA_INDENTINC = 2;
  PARA_INDENTDEC = 3;
  PARA_COLOR = 4;          

procedure TForm1.cmbFontChange(Sender: TObject);
begin
  if (cmbFont.ItemIndex <> -1) then
  begin
    if not IgnoreChanges then
    begin

      RichViewEdit1.SelectAll; 
      fontname := cmbFont.Items[cmbFont.ItemIndex];

      RichViewEdit1.ApplyStyleConversion(TEXT_APPLYFONTNAME);
    end;
  end;
  if Visible then

  RichViewEdit1.Format; 
  RichViewEdit1.SetFocus;
end;                             

[Sergey Tkachenko]

What's your code in OnStyleConversion event?

PS: Format is not needed after editing methods like ApplyStyleConversion.

[wsy211]

Code: Select all

procedure TForm1.RichViewEdit1StyleConversion(Sender: TCustomRichViewEdit;
  StyleNo, UserData: integer; AppliedToText: boolean; var NewStyleNo: integer);
var
  AFontInfo: TFontInfo;
begin
  AFontInfo := TFontInfo.Create(nil);
  try
    AFontInfo.Assign(RVStyle1.TextStyles[StyleNo]);
    case UserData of
      TEXT_APPLYFONTNAME:
       AFontInfo.FontName := Fontname;
      TEXT_APPLYFONTSIZE:
        AFontInfo.Size := FontSize;
    end;

    NewStyleNo := RVStyle1.FindTextStyle(AFontInfo);

  finally
    AFontInfo.Free;
  end;

end;                                            

In cmbFont, an error prompt appears as soon as the font is changed.

[Sergey Tkachenko]

Sorry, I do not see errors in this code.