Вообщем ситуация такова, что невсегда прорисовывается загруженная картинка.
Вот код потока:
| Код |
unit ThreadImg_unit;
interface
uses
ActiveX, Windows, Messages, SysUtils, Variants, Classes, Graphics, GraphicEx;
type
TcmdActions=(cmdIdle,cmdLoad,cmdGenerate,cmdPaint);
ThreadEvent=procedure(cAction:TcmdActions; Msg:String) of object;
TPaintEvent=procedure(const Img:TBitmap)of object;
TDataSize=Record
Width: Cardinal;
Height: Cardinal;
FrameWidth: Cardinal;
FrameHeight: Cardinal;
Top: Cardinal;
Left: Cardinal;
end;
// ВСЕ РАЗМЕРЫ В МИЛЛИМЕТРАХ
TImgThread = class(TThread)
private
//ImageData
Cont: TImage;
prePhoto,
FrameData,
Photo,
Canvas:TBitmap;
pWidth,pHeight,pTop,
pLeft,pRight,pBottom,
FrameHeight: Cardinal;
RealSize: TDataSize;
ImageSize: TDataSize;
Proporion: Real;
t_busy,
t_success,
t_failed: ThreadEvent;
t_repaint: TrepaintEvent;
//GLOBAL VARIABLES
sync_Msg:String;
sync_Action:TcmdActions;
Data: Array of String;
Action:TcmdActions;
_loaded,
SessionFinished,
EndSession,
Running:Boolean;
protected
procedure Execute; override;
procedure Init;
procedure _load;
procedure _generate;
procedure _paintPassparu;
procedure _paintFrame;
procedure _repaint;
procedure _SetSizes(PhotoWidth, PhotoHeight, PasspartuTop, PasspartuLeft, PasspartuRight, PasspartuBottom: Cardinal);
//PRE SYNCHRONIZE
procedure GoBusy(cAction:TcmdActions; Msg:String);
procedure GoFailed(cAction:TcmdActions; Msg:String);
procedure GoSuccess(cAction:TcmdActions; Msg:String);
procedure GoRepaint;
//SYNCHORONIZE
procedure DoBusy;
procedure DoFailed;
procedure DoSuccess;
procedure DoRepaint;
public
property Size:TDataSize read RealSize;
property Loaded:boolean read _loaded;
constructor Create(OnBusy,OnSuccess,OnFailed:ThreadEvent;OnRepaint:TrepaintEvent);
destructor Destroy;override;
procedure LoadFoto(FileName:String);
procedure SetSizes(PhotoWidth,PhotoHeight,PasspartuTop,PasspartuLeft,PasspartuRight,PasspartuBottom:Cardinal);
procedure SetFrame(Height:Cardinal; Img:TBitmap);
procedure Draw;
end;
var MaxSize:Integer=2000;
implementation
{ TImgThread }
constructor TImgThread.Create;
begin
inherited Create(false);
t_busy := OnBusy;
t_Success := OnSuccess;
t_failed := OnFailed;
t_repaint := OnRepaint;
end;
destructor TImgThread.destroy;
begin
EndSession:=True;
repeat
sleep(10);
until SessionFinished;
freeandnil (prePhoto);
freeandnil (Photo);
freeandnil (Canvas);
freeandnil (FrameData);
SetLength (Data,0);
inherited;
end;
procedure TImgThread.DoBusy;
begin
if assigned (t_busy) then t_busy (sync_action, sync_msg);
end;
procedure TImgThread.DoFailed;
begin
if assigned (t_failed) then t_failed (sync_action, sync_msg);
end;
procedure TImgThread.DoRepaint;
begin
if assigned (t_repaint) then t_repaint (Canvas);
end;
procedure TImgThread.DoSuccess;
begin
if assigned (t_success) then t_success (sync_action, sync_msg);
end;
procedure TImgThread.Draw;
begin
if Running then exit;
Action := cmdPaint;
end;
procedure TImgThread.Execute;
begin
CoInitialize (Nil);
Init;
repeat
case Action of
cmdIdle:;
cmdLoad: _load;
cmdGenerate: _generate;
cmdPaint: _repaint;
end;
Sleep(25);
Until EndSession;
SessionFinished := True;
end;
procedure TImgThread.GoBusy(cAction: TcmdActions; Msg: String);
begin
Running := True;
sync_action := cAction;
sync_Msg := MSg;
Synchronize (DoBusy);
end;
procedure TImgThread.GoFailed(cAction: TcmdActions; Msg: String);
begin
sync_action := cAction;
sync_Msg := MSg;
Synchronize (DoFailed);
SetLength (data, 0);
Action := cmdIdle;
Running := False;
end;
procedure TImgThread.GoRepaint;
begin
Synchronize (DoRepaint);
end;
procedure TImgThread.GoSuccess(cAction: TcmdActions; Msg: String);
begin
Running := False;
sync_action := cAction;
sync_Msg := MSg;
Synchronize (DoSuccess);
SetLength (data, 0);
Action := cmdIdle;
end;
procedure TImgThread.Init;
begin
freeandnil (prePhoto);
freeandnil (Photo);
freeandnil (Canvas);
freeandnil (FrameData);
SetLength (Data,0);
_SetSizes (0,0,0,0,0,0);
FrameHeight := 0;
Photo := TBitmap.Create;
Canvas := TBitmap.Create;
prePhoto := TBitmap.Create;
FrameData := TBitmap.Create;
SetStretchBltMode (Canvas.Canvas.Handle, STRETCH_DELETESCANS);
SetStretchBltMode (Photo.Canvas.Handle, STRETCH_DELETESCANS);
SetStretchBltMode (prePhoto.Canvas.Handle, STRETCH_DELETESCANS);
Canvas.Width := MaxSize;
Canvas.Height := MaxSize;
Running := False;
Action := cmdIdle;
end;
procedure TImgThread.LoadFoto(FileName: String);
begin
if Running then exit;
Action := cmdLoad;
SetLength (data,1);
Data[0] := FileName;
end;
procedure TImgThread.SetFrame(Height: Cardinal; Img: TBitmap);
begin
if Running then exit;
Running := True;
FrameHeight := Height;
FrameData := Img;
_setsizes (pWidth,pHeight,pTop,pLeft,pRight,pBottom);
Running := False;
end;
procedure TImgThread.SetSizes(PhotoWidth, PhotoHeight, PasspartuTop,
PasspartuLeft, PasspartuRight, PasspartuBottom: Cardinal);
begin
if Running then exit;
Running:= True;
_SetSizes(PhotoWidth, PhotoHeight, PasspartuTop, PasspartuLeft, PasspartuRight, PasspartuBottom);
Running:= False;
Action:= cmdGenerate;
end;
procedure TImgThread._SetSizes(PhotoWidth, PhotoHeight, PasspartuTop, PasspartuLeft, PasspartuRight, PasspartuBottom: Cardinal);
begin
pWidth:= PhotoWidth;
pHeight:= PhotoHeight;
pTop:= PasspartuTop;
pLeft:= PasspartuLeft;
pRight:= PasspartuRight;
pBottom:= PasspartuBottom;
RealSize.Width:= PhotoWidth;
RealSize.Height:= PhotoHeight;
RealSize.FrameWidth:= PhotoWidth + PasspartuLeft + PasspartuRight + (FrameHeight*2);
RealSize.FrameHeight:= PhotoHeight + PasspartuTop + PasspartuBottom + (FrameHeight*2);
RealSize.Top:= PasspartuTop + FrameHeight;
RealSize.Left:= PasspartuLeft + FrameHeight;
{Вычисление пропроций}
try
if RealSize.FrameWidth>RealSize.FrameHeight
then Proporion:= MaxSize/RealSize.FrameWidth
else Proporion:= MaxSize/RealSize.FrameHeight;
except Proporion:= 0 end;
ImageSize.Height:= Round (RealSize.Height*Proporion);
ImageSize.Width:= Round (RealSize.Width*Proporion);
ImageSize.FrameWidth:= Round (RealSize.FrameWidth*Proporion);
ImageSize.FrameHeight:= Round (RealSize.FrameHeight*Proporion);
ImageSize.Top:= Round (RealSize.Top*Proporion);
ImageSize.Left:=Round(RealSize.Left*Proporion);
end;
procedure TImgThread._generate;
begin
if Running then exit;
GoBusy (Action,'<b>генерация изображения...</b>');
try
Photo.Canvas.FillRect (bounds (0, 0, Photo.Width, Photo.Height));
Photo.Width:= ImageSize.Width;
Photo.Height:= ImageSize.Height;
Photo.Canvas.StretchDraw (bounds (0, 0, ImageSize.Width, ImageSize.Height), prePhoto);
GoSuccess (Action, 'готово');
except on E:Exception do GoFailed (Action, E.Message) end;
Action:= cmdPaint;
end;
procedure TImgThread._load;
var pr:Real;
Fname:String;
begin
if Running then exit;
GoBusy (Action, '<b>загрузка фотографии</b>');
Fname := Data[0];
Init;
try
prePhoto.Width:= 0;
prePhoto.Height:= 0;
Cont:=TImage.Create (nil);
Cont.Picture.LoadFromFile (FName);
if Cont.Picture.Graphic.Width>Cont.Picture.Graphic.Height
then pr:= MaxSize/Cont.Picture.Graphic.Width
else pr:= MaxSize/Cont.Picture.Graphic.Height;
prePhoto.Width:= Round (pr*Cont.Picture.Graphic.Width);
prePhoto.Height:= Round (pr*Cont.Picture.Graphic.Height);
SetStretchBltMode (prePhoto.Canvas.Handle, STRETCH_DELETESCANS);
prePhoto.Canvas.StretchDraw (bounds (0, 0, prePhoto.Width, prePhoto.Height), Cont.Picture.Graphic);
GoSuccess (Action, '<b>загружена фотография: </b>'+FName);
_setsizes(Round (Cont.Picture.Graphic.Width/118.11)*100,Round (Cont.Picture.Graphic.Height/118.11)*100, 0, 0, 0, 0);
freeandnil (Cont);
except on E:Exception do GoFailed(Action, E.Message) end;
Action:= cmdGenerate;
Running:= False;
end;
procedure TImgThread._paintFrame;
begin
{...}
end;
procedure TImgThread._paintPassparu;
begin
{...}
end;
procedure TImgThread._repaint;
begin
if running then exit;
try
GoBusy (Action, 'прорисовка изображения');
Canvas.Canvas.Brush.Color:= clBlack;
Canvas.Width:= ImageSize.FrameWidth;
Canvas.Height:= ImageSize.FrameHeight;
Canvas.Canvas.FillRect (bounds (0, 0, Canvas.Width,Canvas.Height));
_paintPassparu;
_paintFrame;
Canvas.Canvas.Draw(ImageSize.Left,ImageSize.Top, Photo);
GoRepaint;
GoSuccess(Action,'готово');
except on E:Exception do GoFailed(Action,E.Message) end;
end;
end.
|
Вот куски кода главной формы:
| Код |
{...}
private
procedure Busy (cAction:TcmdActions; Msg:String);
procedure Success (cAction:TcmdActions; Msg:String);
procedure Failed (cAction:TcmdActions; Msg:String);
procedure ImgRepaint (const Img:TBitmap);
public
procedure OpenFoto;
{...}
procedure TdefaultFrm.FormCreate(Sender: TObject);
begin
wSync:= TImgThread.Create(Busy, Success, Failed, ImgRepaint);
DoubleBuffered:= True;
end;
procedure TdefaultFrm.OpenFoto;
begin
wSync.LoadFoto (OpenDialog1.FileName);
end;
procedure TdefaultFrm.Busy(cAction: TcmdActions; Msg: String);
begin
{...}
end;
procedure TdefaultFrm.Failed(cAction: TcmdActions; Msg: String);
begin
{...}
end;
procedure TdefaultFrm.Success(cAction: TcmdActions; Msg: String);
begin
{...}
case cAction of
cmdLoad:{...}
cmdGenerate:{...}
cmdPaint:{...}
{...}
end;
end;
procedure TdefaultFrm.ImgRepaint(const Img: TBitmap);
begin
Image1.Picture.Bitmap.Width:= 0;
Image1.Picture.Bitmap.Height:= 0;
Image1.Picture.Bitmap.Width:= Img.Width;
Image1.Picture.Bitmap.Height:= Img.Height;
Image1.Picture.Bitmap.Canvas.Draw (0,0, Img);
end;
|
Но картинка прорисовывается через раз... при этом никаких ошибок (ни в потоке, ни в самом приложении непроисходит)
ЗЫ: грузятся большие картинки (где-то 3х5 тыс пикселей) (JPEG, TIFF, PSD) но сами они прогружаются нормально.
куда копать уже и незнаю... может есть у кого мысли? |
)