Текущий архив: 2006.02.05;
Скачать: CL | DM;

Вниз

Поток и рисование   Найти похожие ветки 

← →
race1   (2006-01-04 13:27) [0]

Есть главное окошко, на нём TPaintBox. Есть поток, в котором делается рисование на TBitmap, который в памяти (задний буфер), потом то что нарисовано копируется на PaintBox.

Проблема в том что если не водить мышкой над формой, всё работает. Если же поводить мышкой или изменить размер окна возникает ошибка EOutOfResources. Но дело в том что я не создаю новых кистей, перьев и т.д., а использую MoveTo\LineTo.

Вот код потока

TWebDraw = class(TThread)
private
 FMemBitmap: TBitmap;
 a:   Real;

 Localxx,
 Localyy,
 LocalR:  WORD;

 procedure UpdatePaintBox;

public
 bmpWidth: WORD;
 bmpHeight: WORD;
 xx, yy:   WORD;
 R:  WORD;

protected
 procedure Execute; override;
end;

WebDraw: TWebDraw;
...
procedure TWebDraw.UpdatePaintBox;
begin
frmMain.PaintBox.Canvas.Draw(0, 0, FMemBitmap);
end;

procedure TWebDraw.Execute;
var
c: Real;
i: Integer;
t: Real;
x, y: Real;
x2, y2: Real;
rct: TRect;

begin
FMemBitmap := TBitmap.Create;

while not Terminated do
begin
 Sleep(10);

 if (FMemBitmap.Width <> bmpWidth) or (FMemBitmap.Height <> bmpHeight) then
 begin
  // Если раскомментировать эти две строки
  // всё работает нормально. Почти...
  //FMemBitmap.Free;
  //FMemBitmap := TBitmap.Create;
  FMemBitmap.Width := bmpWidth;
  FMemBitmap.Height := bmpHeight;
 end;
 ...
 rct := Rect(0, 0, FMemBitmap.Width, FMemBitmap.Height);
 FMemBitmap.Canvas.FillRect(rct);
 ...
 while i <= 360 do
 begin
  ...
  FMemBitmap.Canvas.Pen.Color := RGB(360 - i, i - 360, i);
  FMemBitmap.Canvas.MoveTo(Round(x + Localxx), Round(y + Localyy));
  FMemBitmap.Canvas.LineTo(Round(x2 + Localxx), Round(y2 + Localyy));

  Inc(i, 2);
 end;

 Synchronize(UpdatePaintBox);
end;
end;
...


А вот код главной формы

...
procedure TfrmMain.FormResize(Sender: TObject);
begin
// Сдесь меняем размеры заднего буфера потока
// Сначала приостанавливаем поток, потом задаём новые размеры
// и продолжаем выполнение потока
WebDraw.Suspend;
WebDraw.bmpWidth := PaintBox.Width;
WebDraw.bmpHeight := PaintBox.Height;

WebDraw.xx := PaintBox.Width div 2;
WebDraw.yy := PaintBox.Height div 2;
WebDraw.R := Min(WebDraw.xx - 10, WebDraw.yy - 10);
WebDraw.Resume;
end;
...
procedure TfrmMain.FormCreate(Sender: TObject);
begin
WebDraw := TWebDraw.Create(True);
WebDraw.bmpWidth := PaintBox.Width;
WebDraw.bmpHeight := PaintBox.Height;

WebDraw.xx := PaintBox.Width div 2;
WebDraw.yy := PaintBox.Height div 2;
WebDraw.R := Min(WebDraw.xx - 10, WebDraw.yy - 10);
WebDraw.Resume;
end;
...


---

← →
race1   (2006-01-05 12:41) [1]

Удалено модератором
Примечание: Создание пустых сообщений

---

← →
Eraser ©   (2006-01-05 16:22) [2]

> race1   (05.01.06 12:41) [1]
>
> Никто не знает?

Я знаю одно, что программу переписывать надо. Зачем вообще тут эта затея с дополнительным потоком?

---

← →
race1   (2006-01-05 17:11) [3]

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

---

← →
Eraser ©   (2006-01-05 17:44) [4]

> race1   (05.01.06 17:11) [3]

Ну допустим так. Но прорисовку на пэинт бокс необходимо осущетвлять через событие OnPaint, а не через мифический UpdatePaintBox. А инициировать прорисовку ф-ей InvalidateRect или какая-там её обёртка у пэинт бокса...

---

← →
race1   (2006-01-05 18:06) [5]

>Eraser
Да вобще-то думаю без разницы, перерисовка происходит очень быстро, картинка просто не успеет затереться. А ведь нету ничего криминального в простом копировании картинки на экран?

Но всё равно это проблемы не снимает. По прежнему если поводить мышкой над формой происходит косяк. Я не понимаю вобще - ну какая связь между мышкой и потоком и копированием картинки! Кстати, если клавиатуру нажимать тоже самое :(

---

← →
Eraser ©   (2006-01-05 19:09) [6]

> race1   (05.01.06 18:06) [5]

так сходу непонятно почему.
НО, обращения к Canvas из доп. потока у тебя не защищено.
Добавь перед frmMain.PaintBox.Canvas.Draw(0, 0, FMemBitmap);
frmMain.PaintBox.Canvas.Lock;
а после
frmMain.PaintBox.Canvas.Unlock;
... а вообще конечно лучше через InvalidateRect.

---

← →
race1   (2006-01-06 07:36) [7]

Я этот делал, не помогло. Так же делал через Refresh.

Ещё я убрал Synchronize вообще, поводил мышкой и... EOutOfResources! А если закомментировать рисование:

FMemBitmap.Canvas.Pen.Color := RGB(360 - i, i - 360, i);
FMemBitmap.Canvas.MoveTo(Round(x + Localxx), Round(y + Localyy));
FMemBitmap.Canvas.LineTo(Round(x2 + Localxx), Round(y2 + Localyy));

и включить обратно Synchronize, то ошибок не возникает.

---

← →
Набережных С. ©   (2006-01-06 17:28) [8]

> race1

Использование в доп. потоках дельфийских графических классов - не самая удачная идея, из-за кеширования граф. контекста прежде всего. Насколько я понимаю, более-менее нормального результата можно добиться, если при каждой перерисовке создавать новый TBitmap, если только это можно назвать нормальным результатом. Да и то, есть у меня сомнения в полной надежности такой метОды. Так что нужно переходить на API, если действительно в данном случае есть такая необходимость - рисовать непрерывно в доп. потоке, в чем я лично  сомневаюсь.

Вот пример такой реализации, а уж поможет ли, нет ли - от тебя зависит.
Проверки на ошибки я убрал, чтобы код был прозрачней, но в реальности они необходимы. И еще одно: я не шибкий спец в графике, здесь, скорее всего, не все оптимально. Однако же и грубых ошибок нет.

DFM:

object Form1: TForm1
 Left = 413
 Top = 114
 Width = 410
 Height = 418
 Caption = "Form1"
 Color = clBtnShadow
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = "MS Sans Serif"
 Font.Style = []
 OldCreateOrder = False
 OnCreate = FormCreate
 OnDestroy = FormDestroy
 OnResize = FormResize
 PixelsPerInch = 96
 TextHeight = 13
 object Panel1: TPanel
   Left = 0
   Top = 347
   Width = 402
   Height = 37
   Align = alBottom
   Font.Charset = DEFAULT_CHARSET
   Font.Color = clWindowText
   Font.Height = -11
   Font.Name = "MS Sans Serif"
   Font.Style = []
   ParentBackground = False
   ParentFont = False
   TabOrder = 0
   DesignSize = (
     402
     37)
   object Button1: TButton
     Left = 243
     Top = 6
     Width = 75
     Height = 25
     Anchors = [akRight, akBottom]
     Caption = "Start"
     Default = True
     TabOrder = 0
     OnClick = Button1Click
   end
   object Button2: TButton
     Left = 323
     Top = 6
     Width = 75
     Height = 25
     Anchors = [akRight, akBottom]
     Cancel = True
     Caption = "Stop"
     TabOrder = 1
     OnClick = Button2Click
   end
 end
 object Panel2: TPanel
   Left = 0
   Top = 0
   Width = 402
   Height = 347
   Align = alClient
   BevelInner = bvLowered
   ParentColor = True
   TabOrder = 1
   object PaintBox1: TPaintBox
     Left = 2
     Top = 2
     Width = 398
     Height = 343
     Align = alClient
     OnPaint = PaintBox1Paint
   end
 end
end


---

← →
Набережных С. ©   (2006-01-06 17:29) [9]

Модуль:

unit MainUnit;

interface

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

const
 DTM_REPAINT = WM_USER + 411;
 DTM_RESIZE  = DTM_REPAINT + 1;

type
 TDrawThread = class(TThread)
 private
   FBmp: HBITMAP;
   FHollowBrush: HBrush;
   FCS: TRTLCriticalSection;
   FShift: integer;
   FMaxRadius: integer;
   FCenter: TPoint;
   FWidth, FHeight: integer;
   FPaintDC: HDC;
   FReceiver: HWND;
   procedure DoResize(ImgWidth, ImgHeight: integer);
   procedure DoTimer;
   procedure CreateImage;
   procedure DeleteImage;
 protected
   procedure Execute; override;
   procedure Repaint;
 public
   constructor Create(AReceiver: HWND; ImgWidth, ImgHeight: integer);
   destructor Destroy; override;
   procedure Terminate;
   function LockImage: HBitmap;
   procedure UnlockImage;
   procedure ChangePaintArea(AWidth, AHeight: integer);
 end;

 TForm1 = class(TForm)
   Panel1: TPanel;
   Button1: TButton;
   Button2: TButton;
   Panel2: TPanel;
   PaintBox1: TPaintBox;
   procedure FormResize(Sender: TObject);
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure PaintBox1Paint(Sender: TObject);
   procedure Button1Click(Sender: TObject);
   procedure Button2Click(Sender: TObject);
 private
   { Private declarations }
   FDrawThread: TDrawThread;
   FImageDC: HDC;
   procedure DtmRepaint(var Message); message DTM_REPAINT;
   procedure DeleteThread;
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}
{$R WindowsXP.res}

{ TDrawThread }

const
 MaxShift = 20;

constructor TDrawThread.Create(AReceiver: HWND; ImgWidth, ImgHeight: integer);
begin
 InitializeCriticalSection(FCS);
 FWidth:= ImgWidth;
 FHeight:= ImgHeight;
 FReceiver:= AReceiver;
 inherited Create(false);
end;

destructor TDrawThread.Destroy;
begin
 inherited;
 if nil <> FCS.DebugInfo then DeleteCriticalSection(FCS);
end;

procedure TDrawThread.DoTimer;
begin
 LockImage;
 try
   Inc(FShift);
   if MaxShift = FShift then FShift:= 0;
   Repaint;
 finally
   UnlockImage;
 end;
end;

procedure TDrawThread.Execute;
var
 TimerID: Cardinal;
 Msg: TMsg;
begin
 TimerID:= SetTimer(0, 0, 20, nil);
 try
   CreateImage;

   while GetMessage(Msg, 0, 0, 0) do
     case Msg.message of

       DTM_RESIZE: DoResize(Msg.wParam, Msg.lParam);
       WM_TIMER:   DoTimer;

     end;  

 finally
   DeleteImage;
   KillTimer(0, TimerID);
 end;
end;

function TDrawThread.LockImage: HBitmap;
begin
 EnterCriticalSection(FCS);
 Result:= FBmp;
end;

procedure TDrawThread.ChangePaintArea(AWidth, AHeight: integer);
begin
 PostThreadMessage(ThreadID, DTM_RESIZE, AWidth, AHeight);
end;

procedure TDrawThread.CreateImage;
var
 Info: TLogBrush;
begin
 FPaintDC:= CreateCompatibleDC(0);

 with Info do
 begin
   lbStyle:= BS_HOLLOW;
   lbColor:= 0;
   lbHatch:= 0;
 end;
 FHollowBrush:= CreateBrushIndirect(Info);
 
 DoResize(FWidth, FHeight);
end;

procedure TDrawThread.DeleteImage;
begin
 if 0 <> FHollowBrush then DeleteObject(FHollowBrush);
 if 0 <> FPaintDC then DeleteDC(FPaintDC);
 if 0 <> FBmp then DeleteObject(FBmp);
end;

procedure TDrawThread.Repaint;
var
 SaveBmp: HBITMAP;
 Radius: integer;
 SaveBrush: HBRUSH;
begin
 SaveBmp:= SelectObject(FPaintDC, FBmp);
 FillRect(FPaintDC, Rect(0, 0, FWidth, FHeight), 0);
 SaveBrush:= SelectObject(FPaintDC, FHollowBrush);

 Radius:= 1 + FShift;
 while Radius < FMaxRadius do
 begin
   Ellipse(FPaintDC, FCenter.X - Radius, FCenter.Y - Radius,
                     FCenter.X + Radius, FCenter.Y + Radius);
   Inc(Radius, MaxShift);
 end;

 SelectObject(FPaintDC, SaveBrush);
 SelectObject(FPaintDC, SaveBmp);

 PostMessage(FReceiver, DTM_REPAINT, 0, 0);
end;

procedure TDrawThread.DoResize(ImgWidth, ImgHeight: integer);
begin
 LockImage;
 try
   if 0 <> FBmp then DeleteObject(FBmp);
   FBmp:= CreateCompatibleBitmap(FPaintDC, ImgWidth, ImgHeight);
   FWidth:=  ImgWidth;
   FHeight:= ImgHeight;
   FCenter:= Point(ImgWidth shr 1, ImgHeight shr 1);
   FMaxRadius:= Round(Sqrt(ImgWidth * ImgWidth + ImgHeight * ImgHeight) / 2);
   Repaint;
 finally
   UnlockImage;
 end;
end;

procedure TDrawThread.Terminate;
begin
 inherited Terminate;
 PostThreadMessage(ThreadID, WM_QUIT, 0, 0);
end;

procedure TDrawThread.UnlockImage;
begin
 LeaveCriticalSection(FCS);
end;

{ TForm1 }

procedure TForm1.FormResize(Sender: TObject);
begin
 if nil <> FDrawThread then
   FDrawThread.ChangePaintArea(PaintBox1.Width, PaintBox1.Height);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 FImageDC:= CreateCompatibleDC(PaintBox1.Canvas.Handle);
 Button1.Click;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 DeleteThread;
 if 0 <> FImageDC then DeleteDC(FImageDC);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
var
 ImageBmp, SaveBmp: HBitmap;
begin
 if nil <> FDrawThread then
 begin
   ImageBmp:= FDrawThread.LockImage;
   try
     SaveBmp:= SelectObject(FimageDC, ImageBmp);
     with PaintBox1, Canvas do
       BitBlt(Handle, 0, 0, Width, Height, FimageDC, 0, 0, SRCCOPY);
     SelectObject(FimageDC, SaveBmp);
   finally
     FDrawThread.UnlockImage;
   end;
 end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 DeleteThread;
 FDrawThread:= TDrawThread.Create(Handle, PaintBox1.Width, PaintBox1.Height);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 DeleteThread;
 PaintBox1.Invalidate;
end;

procedure TForm1.DeleteThread;
begin
 if nil <> FDrawThread then
 begin
   FDrawThread.Terminate;
   FDrawThread.Free;
   FDrawThread:= nil;
 end;
end;

procedure TForm1.DtmRepaint(var Message);
var
 R: TRect;
begin
 R:= PaintBox1.BoundsRect;
 InvalidateRect(PaintBox1.Parent.Handle, @R, false);
end;

end.


---

← →
Eraser ©   (2006-01-06 18:02) [10]

> Набережных С. ©   (06.01.06 17:28) [8]


> из-за кеширования граф. контекста прежде всего.

хм... а что за кеширование контекста, можете пояснить? Возможно это кэширование можно очистить с пом. GdiFlush?
На сколько мне известно класс TCanvas разрабатывался с учётом возможности его использовать в нескольких потоках, именно для этого там есть методы Lock/Unlock, которые защищают прорисовку критической секцией.
А при активной работе с TBitmap в доп. треде у меня тоже не раз возникала эта злополучная EOutOfResources, но каждый раз оказывалось, что виноват не TBitmap, а кривость моего алгоритма.

---

← →
race1   (2006-01-06 18:19) [11]

>Набережных С.
Спасибо, работает замечательно :) Не так компактно, как хотелось, для такой небольшой задачи...

Попробовал вынести рисование в главный поток и поставил ProcessMessages, работает нормально, тормозов не заметно

---

← →
Набережных С. ©   (2006-01-06 19:35) [12]

> Eraser ©   (06.01.06 18:02) [10]


> Возможно это кэширование можно очистить с пом. GdiFlush?

Очень может быть. Во всяком случае, я не проверял - по той причине, что я по-просту не знал о ее существовании. Во всяком случае, ее описание достаточно созвучно моим представлениям о существе проблемы. Однако позволю себе процитировать самого себя:

> я не шибкий спец в графике

Мне это просто не было нужно. И мои заключения основаны на непродолжительных и давних экспирементах, которые я частично "освежил" сегодня. Посему Вам следует самому проверить действенность упомянутой функции, если это Вас реально интересует. Я же полагаю, что автор ветки принял правильное решение, перенеся отрисовку в основной поток.

В заключение вынужден, однако же, напомнить Вам о некой договоренности, достигнутой между мной и Вами какое-то время назад. И попросить Вас неукоснительно ее соблюдать в дальнейшем.

---

← →
Eraser ©   (2006-01-07 02:03) [13]

Offtop:

> Набережных С. ©   (06.01.06 19:35) [12]


> В заключение вынужден, однако же, напомнить Вам о некой
> договоренности, достигнутой между мной и Вами какое-то время
> назад.
>

"Я не злопамятный, но злой и память у меня хорошая" (c)

> И попросить Вас неукоснительно ее соблюдать в дальнейшем.

OK ;-)

---

Страницы: 1 вся ветка

Текущий архив: 2006.02.05;
Скачать: CL | DM;

Наверх

Память: 0.53 MB
Время: 0.029 c