Решение проблемы с собственным отрисовкой компонента в Lazarus и FreePascal

Delphi , Компоненты и Классы , TImage и TImageList

Создание собственных компонентов в Lazarus и FreePascal (FPC) — это мощный инструмент для разработки пользовательских интерфейсов. Однако, как и в любом другом языке программирования, при работе с графикой могут возникать определенные сложности. В данной статье мы рассмотрим проблему, с которой столкнулся пользователь при попытке нарисовать кастомный компонент на основе TCustomControl, а также предложим решение этой проблемы.

Описание проблемы

Пользователь, переходящий из мира C++ и Python, столкнулся с проблемой при попытке создать кастомный компонент в Lazarus на основе TCustomControl. Целью было создание компонента, который будет отрисовывать на TCanvas определенные данные. Однако при попытке нарисовать рамку и фон компонента, он обнаружил, что вместо этого отрисовывается только изображение, загруженное в TPicture.

Анализ проблемы

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

Код компонента

unit RPreview;
{$mode ObjFPC}{$H+}
interface
uses
  Classes, Sysutils, REngine, Controls, graphics, lcltype;

type
  TRPreview = class(TCustomControl)
  private
    _mprod: Extended;
    _rprod: Extended;
    _owned: Boolean;
    _type: ReactorType;
    _props: TReactorProperties;
    _img: TPicture;
  public
    constructor Create(AOwner: TComponent);
    procedure Free;
    procedure Paint; override;
    procedure EraseBackground(DC: HDC); override;
  end;

implementation

constructor TRPreview.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  _mprod := 0;
  _rprod := 0;
  _owned := false;
  _type := rtNone;
  _img := TPicture.Create;
end;

procedure TRPreview.setType(t: ReactorType);
var
  res: String;
begin
  if t = rtNone then Exit;
  _type := t;
  // cut out out of context code
  _img.LoadFromResourceName(HINSTANCE, res, TPortableNetworkGraphic);
end;

procedure TRPreview.Free;
begin
  _img.Free;
  inherited Free;
end;

procedure TRPreview.Paint;
var
  b: TBrush;
  p: TPen;
begin
  if _type = rtNone then exit;
  b := TBrush.Create;
  p := TPen.Create;
  b.Color := clBlack;
  b.Style := bsSolid;
  Canvas.Brush := b;
  Canvas.FillRect(Left + 4, Top + 4, Left + Width - 4, Top + Height - 4);
  b.Free;
  p.Free;
  Inherited Paint;
end;

procedure TRPreview.EraseBackground(DC: HDC);
begin
  // Inherited EraseBackground(DC);
end;

end.

Код формы

procedure TForm1.FormCreate(Sender: TObject);
var
  t: ReactorType;
  dx, dy, cx: Integer;
begin
  bkg := TPicture.Create;
  dx := (Width div 2) - (2 * 180) - 90;
  dy := 7 * 25;
  cx := 1;
  bkg.LoadFromResourceName(HInstance, 'BACKGROUND', TPortableNetworkGraphic);
  brush.Bitmap := bkg.Bitmap;
  Canvas.FloodFill(0, 0, clDefault, fsSurface);
  Engine := TEngine.Create;
  for t := rtIsland to rtContinent do
  begin
    if t = rtNone then continue;
    boxes[t] := TRPreview.Create(Self);
    boxes[t].Parent := Self;
    boxes[t].Width := 170;
    boxes[t].Height := 170;
    boxes[t].Left := dx;
    boxes[t].Top := dy;
    boxes[t].RType := t;
    boxes[t].DoubleBuffered := true;
    cx += 1;
    if cx = 6 then
    begin
      dx := (Width div 2) - (2 * 180) - 90;
      dy += 180;
    end
    else
      dx += 180;
  end;
end;

Проблема и её причины

1. Отсутствие отрисовки рамки и фона: В методе Paint компонента TRPreview пользователь пытается нарисовать рамку и фон, но вместо этого отображается только изображение, загруженное в TPicture. Это может быть связано с тем, что метод Paint не был вызван должным образом или были проблемы с настройкой TCanvas.

2. Поведение на разных платформах: Пользователь отметил, что на Windows все работает корректно, а на Linux/GTK отображается только белый фон. Это может быть связано с различиями в реализации графических библиотек на разных платформах.

Решение проблемы

Для решения проблемы необходимо убедиться, что метод Paint компонента вызывается корректно и что все необходимые настройки TCanvas выполнены. Также нужно убедиться, что компонент корректно обрабатывает события обновления и перерисовки.

1. Убедиться, что метод Paint вызывается корректно

Метод Paint должен быть вызван автоматически при необходимости перерисовки компонента. Если метод Paint не вызывается, необходимо убедиться, что компонент корректно обрабатывает события обновления и перерисовки. Это можно сделать, установив свойство DoubleBuffered в True и убедившись, что метод Paint вызывается при необходимости.

procedure TRPreview.Paint;
var
  b: TBrush;
  p: TPen;
begin
  inherited;
  if _type = rtNone then exit;
  b := TBrush.Create;
  p := TPen.Create;
  b.Color := clBlack;
  b.Style := bsSolid;
  Canvas.Brush := b;
  Canvas.FillRect(Left + 4, Top + 4, Left + Width - 4, Top + Height - 4);
  b.Free;
  p.Free;
end;

2. Убедиться, что все необходимые настройки TCanvas выполнены

Убедитесь, что все необходимые настройки TCanvas выполнены перед вызовом метода Paint. Это включает установку цвета кисти, ширины и стиля пера, а также установку свойства DoubleBuffered в True.

3. Обработка событий обновления и перерисовки

Убедитесь, что компонент корректно обрабатывает события обновления и перерисовки. Это можно сделать, установив свойство DoubleBuffered в True и убедившись, что метод Paint вызывается при необходимости.

4. Проверка на разных платформах

Пользователь отметил, что на Windows все работает корректно, а на Linux/GTK отображается только белый фон. Это может быть связано с различиями в реализации графических библиотек на разных платформах. Для решения этой проблемы можно использовать платформенно-зависимые условные компиляции или использовать библиотеки, которые обеспечивают единое API для всех платформ.

Альтернативное решение

Если проблема с отрисовкой на Linux/GTK не решается, можно рассмотреть альтернативное решение, которое использует TBitmap для отрисовки компонента. Это может помочь избежать проблем с отрисовкой на различных платформах.

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

procedure TRPreview.Paint;
var
  b: TBrush;
  p: TPen;
  bitmap: TBitmap;
begin
  inherited;
  if _type = rtNone then exit;
  bitmap := TBitmap.Create;
  try
    bitmap.Width := Width;
    bitmap.Height := Height;
    b := TBrush.Create;
    p := TPen.Create;
    b.Color := clBlack;
    b.Style := bsSolid;
    bitmap.Canvas.Brush := b;
    bitmap.Canvas.FillRect(0, 0, bitmap.Width, bitmap.Height);
    bitmap.Canvas.RoundRect(4, 4, bitmap.Width - 4, bitmap.Height - 4, 5, 5);
    p.Width := 5;
    p.Color := clGray;
    bitmap.Canvas.Pen := p;
    bitmap.Canvas.RoundRect(4, 4, bitmap.Width - 4, bitmap.Height - 4, 5, 5);
    Canvas.Draw(0, 0, bitmap);
  finally
    bitmap.Free;
    b.Free;
    p.Free;
  end;
end;

Заключение

В данной статье мы рассмотрели проблему, с которой столкнулся пользователь при попытке создать кастомный компонент в Lazarus на основе TCustomControl. Мы предложили несколько решений этой проблемы, включая убедительное вызов метода Paint, правильную настройку TCanvas и использование TBitmap для отрисовки компонента. Также мы рассмотрели альтернативное решение, которое может помочь избежать проблем с отрисовкой на различных платформах.

Создано по материалам из источника по ссылке.

Статья посвящена созданию пользовательских компонентов в Lazarus и FreePascal (FPC), рассматривая проблему отрисовки кастомного компонента на основе `TCustomControl` и предлагая решения для её устранения.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: TImage и TImageList ::