Вызов события OnPaint из другого потока

SpectraL · #1 15.03.2015, 19:22

Скажите пожалуйста, как правильно вызвать событие TForm1.PaintBox1Paint из TThread.Execute?

Код:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Unit2, Vcl.ExtCtrls;

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
  Thread1 := TThread1.Create;
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  BitBlt(Form1.PaintBox1.Canvas.Handle, 0, 0, Bitmap1.Width, Bitmap1.Height, Bitmap1.Canvas.Handle, 0, 0, SrcCopy); // копируем изображение из Bitmap1 в PaintBox1
end;

end.

Код:

unit Unit2;

interface

uses
  System.Classes, Vcl.Graphics;

type
  TThread1 = class(TThread)
  protected
    procedure Execute; override;
  end;

var
  Thread1: TThread1;
  Bitmap1: TBitmap;

implementation

uses
  Unit1;

procedure TThread1.Execute;
begin
  Bitmap1 := TBitmap.Create;
  Bitmap1.SetSize(Form1.PaintBox1.Width, Form1.PaintBox1.Height); // определяем размер изображения (создаём его)
  Synchronize(procedure
  begin
    Form1.PaintBox1Paint(Nil);
  end);
end;

end.

Alex_4444 · #2 15.03.2015, 20:01

1) В модуле с потоком приготовь заранее процедуру синхронизации с главной формой.
2) Что за битмап? Битмап надо передать главной форме в процедуре синхронизации.
3) Как правило: всё, что принадлежит главной форме (размер её компонентов, сами компоненты и т.д.), считывается или изменяется только в процедуре синхронизации. (Иначе глюков не оберёшься)
4) Form1.PaintBox1Paint(Form1) - не надо nil-ов в потоках. Кто-то должен отвечать за происходящее в системе.

SpectraL · #3 16.03.2015, 10:06

"Form1.PaintBox1Paint(Form1);" - это же просто вызов, поэтому можно использовать без синхронизации?

NumLock · #4 16.03.2015, 10:39

а из потока посылать сообщение форме, а она уже сама заставит PaintBox перерисоваться:

Код:

PostMessage(Form1.Handle, CM_INVALIDATE, 0, 0);

полный код:

Код:

unit Unit1;

interface

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

type
  TMyThread = class(TThread)
  protected
    procedure Execute; override;
  end;

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

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TMyThread }

procedure TMyThread.Execute;
begin
  while true do
  begin
    PostMessage(Form1.Handle, CM_INVALIDATE, 0, 0);
    Sleep(33);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  TMyThread.Create(False);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  PaintBox1.Canvas.Brush.Color:=clInfoBk;
  PaintBox1.Canvas.FillRect(PaintBox1.ClientRect);
  PaintBox1.Canvas.Font.Color:=clInfoText;
  PaintBox1.Canvas.TextOut(0, 0, IntToStr(GetTickCount));
end;

end.

SpectraL · #5 16.03.2015, 12:52

Почему постоянно вызывается событие OnPaint, если в его процедуру добавить ShowMessage, а на форму добавить TButton?

Код:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    Button1: TButton;
    procedure PaintBox1Paint(Sender: TObject);
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  ShowMessage('yes')
end;

end.

Alex_4444 · #6 16.03.2015, 16:30

использовал код NumLock-а? Там же просто пример. Поэтому у тебя каждые 33 наносекунды окно выскакивает))))Нужно вникать в код же)))
Под твою задачу как-то так:

Код:

unit Unit2;
 
interface
 
uses
  System.Classes, Vcl.Graphics;
 
type
  TThread1 = class(TThread)
  protected
    procedure Execute; override;
    procedure RepaintPaintBox(Bitmap : TBitmap);
  end;
 
var
  Thread1: TThread1;
  Bitmap1: TBitmap;
 
implementation
 
uses
  Unit1;
 
procedure TThread1.Execute;
begin
  Bitmap1 := TBitmap.Create;
  // делай со своим битмапом что угодно затем отдавай форме

  Synchronize(RepaintPaintBox(Bitmap1));

  Bitmap1.Free;
  
end;

procedure TThread1.RepaintPaintBox(Bitmap : TBitmap);
begin
   Form1.RepaintMyPaintBoxPlease(Bitmap);
end;
 
end.

Ну а главный модуль как-то так:

Код:

unit Unit1;
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Unit2, Vcl.ExtCtrls;
 
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure PaintBox1Paint(Sender: TObject);
    public
    bitmap1 : TBitmap;
    procedure RepaintMyPaintBoxPlease(Bitmap: TBitmap);
  end;
 
var
  Form1: TForm1;

 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    Bitmap1.Free;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
   Bitmap1 := TBitmap.create;
   Thread1 := TThread1.Create;
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  // эта процедура нам по сути не нужна ))))
end;

procedure RepaintMyPaintBoxPlease(Bitmap: TBitmap);
begin
    Bitmap1.Assign(Bitmap);
    // копируем изображение из Bitmap1 в PaintBox1
    BitBlt(Form1.PaintBox1.Canvas.Handle, 0, 0,
             Bitmap1.Width,  Bitmap1.Height,
             Bitmap1.Canvas.Handle, 0, 0, SrcCopy);
    PaintBox1.Repaint;
end; 

end.

SpectraL · #7 17.03.2015, 19:58

При рисовании по событию OnResize программа зависает. Эту проблему решает процедура Sleep. Можете ещё что-нибудь порекомендовать или использование процедуры Sleep то что надо?

Код:

unit Unit1;

// Form1.Anchors = [akLeft,akTop,akRight,akBottom]
 
interface
 
uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.ExtCtrls, Unit2;
 
type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  Thread1 := TThread1.Create
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  Thread1.Suspended := False; // запускаем итерацию рисования
  Sleep(10)
end;
 
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  BitBlt(Form1.PaintBox1.Canvas.Handle, 0, 0, Bitmap1.Width, Bitmap1.Height,
  Bitmap1.Canvas.Handle, 0, 0, SrcCopy) // копируем изображение из Bitmap1 в PaintBox1
end;
 
end.

Код:

unit Unit2;
 
interface
 
uses
  System.Classes, Vcl.Graphics;
 
type
  TThread1 = class(TThread)
  protected
    procedure Execute; override;
  end;
 
var
  Thread1: TThread1;
  Bitmap1: TBitmap;
 
implementation
 
uses
  Unit1;
 
procedure TThread1.Execute;
begin
  Bitmap1.Canvas.Lock; // блокируем холст от других потоков

  repeat
    Bitmap1.SetSize(Form1.PaintBox1.Width, Form1.PaintBox1.Height); // определяем размер изображения (создаём его)
    Form1.PaintBox1Paint(Nil); // передаём изображение в PaintBox1
    Thread1.Suspended := True // приостанавливаем поток
  until Thread1.Terminated
end;

initialization

Bitmap1 := TBitmap.Create

finalization

Bitmap1.Canvas.Unlock; // разблокируем холст
Bitmap1.Free

end.

NumLock · #8 18.03.2015, 08:11

все неправильно!

SpectraL · #9 18.03.2015, 10:26

Цитата:

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

все неправильно!

Всё идеально.

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

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

Этот пользователь сказал Спасибо Alex_4444 за это полезное сообщение:
SpectraL (15.03.2015)

Этот пользователь сказал Спасибо NumLock за это полезное сообщение:
SpectraL (16.03.2015)