Mirror

Add formatted line (with TAGs) to TRichEdit - ready function (Views: 101)


Problem/Question/Abstract:

Add formatted line (with TAGs) to TRichEdit - ready function

Answer:

procedure AddRichLine(RichEdit: TRichEdit; const StrToAdd: string);
var
  StrLeft: string;
  TempStyle: TFontStyles;
  TempStr: string;

  function FromLeftUntilStr(var OriginalStr: string; const UntilStr: string; const
    ToEndIfNotFound, Trim: Boolean): string;
  var
    TempPos: Integer;
  begin
    TempPos := Pos(UntilStr, OriginalStr);
    if TempPos > 0 then
    begin
      Result := Copy(OriginalStr, 1, TempPos - 1);
      if Trim then
        Delete(OriginalStr, 1, TempPos - 1);
    end
    else
    begin
      if ToEndIfNotFound then
      begin
        Result := OriginalStr;
        if Trim then
          OriginalStr := '';
      end
      else
        Result := '';
    end;
  end;

  function StrStartsWith(var OriginalStr: string; const StartsWith: string; const
    IgnoreCase, Trim: Boolean): Boolean;
  var
    PartOfOriginalStr: string;
    NewStartsWith: string;
  begin
    PartOfOriginalStr := Copy(OriginalStr, 1, Length(StartsWith));
    NewStartsWith := StartsWith;

    if IgnoreCase then
    begin
      PartOfOriginalStr := LowerCase(PartOfOriginalStr);
      NewStartsWith := LowerCase(NewStartsWith);
    end;

    Result := PartOfOriginalStr = NewStartsWith;

    if (Result = True) and (Trim = True) then
      Delete(OriginalStr, 1, Length(NewStartsWith));
  end;

  procedure AddToStyle(var Style: TFontStyles; AStyle: TFontStyle);
  begin
    if not (AStyle in Style) then
      Style := Style + [AStyle];
  end;

  procedure RemoveFromStyle(var Style: TFontStyles; AStyle: TFontStyle);
  begin
    if AStyle in Style then
      Style := Style - [AStyle];
  end;
begin
  TempStyle := RichEdit.Font.Style;
  StrLeft := StrToAdd;
  RichEdit.SelStart := Length(RichEdit.Text);
  while StrLeft <> '' do
  begin
    if StrStartsWith(StrLeft, '<', True, False) then
    begin
      // Bold Style
      if StrStartsWith(StrLeft, '', True, True) then
        AddToStyle(TempStyle, fsBold);
      if StrStartsWith(StrLeft, '', True, True) then
        RemoveFromStyle(TempStyle, fsBold);

      // Italic Style
      if StrStartsWith(StrLeft, '', True, True) then
        AddToStyle(TempStyle, fsItalic);
      if StrStartsWith(StrLeft, '', True, True) then
        RemoveFromStyle(TempStyle, fsItalic);

      // Underline Style
      if StrStartsWith(StrLeft, '', True, True) then
        AddToStyle(TempStyle, fsUnderline);
      if StrStartsWith(StrLeft, '', True, True) then
        RemoveFromStyle(TempStyle, fsUnderline);

      // Color
      if StrStartsWith(StrLeft, '', True, True) then
        RichEdit.SelAttributes.Color := RichEdit.Font.Color;
      if StrStartsWith(StrLeft, '', False, True);
      try
        RichEdit.SelAttributes.Color := StringToColor(TempStr);
      except
        RichEdit.SelAttributes.Color := RichEdit.Font.Color;
      end;
      Delete(StrLeft, 1, 1);
    end;
  end
else
  begin
    RichEdit.SelAttributes.Style := TempStyle;
    RichEdit.SelText := FromLeftUntilStr(StrLeft, '<', True, True);
  end;

  RichEdit.SelStart := Length(RichEdit.Text);
end;
RichEdit.SelText := #13#10;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  AddRichLine(RichEdit1,
    'Test: This is a bold test line which is written in blue. Nice?');
end;

<< Back to main page