Question

这是运行一个线程的代码的小片段（准备粘贴并运行）。该线程获取光盘上的jpg文件列表，然后对其执行某些操作。

通常它可以正常工作。如果我开始在表单上移动光标，我每次都会收到此错误：）

任何想法？谢谢！

unit uTest;

interface

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

type
  TThreadSafeJpegImage = class(TJPEGImage)
  protected
    procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  end;

  TForm1 = class(TForm)
    btn1: TButton;
    procedure btn1Click(Sender: TObject);
  private    
  public    
  end;

  TWatek = class(TThread)
  public
    procedure Execute;override;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.btn1Click(Sender: TObject);
var
  thr: TWatek;
begin
  thr := TWatek.Create(true);
  thr.FreeOnTerminate := true;
  thr.Resume;
end;

{ TWatek }

procedure TWatek.Execute;
var
  sciezka: string;
  Rec : TSearchRec;
  Path : string;
  I: Integer;

  function TestFile(path: string): WideString;
  var
    stream: TMemoryStream;
    jpg: TThreadSafeJpegImage;
    bmp32: TBitmap32;
    strStr: TStringStream;
    err: String;
  begin
    try
      stream := TMemoryStream.Create;
      jpg := TThreadSafeJpegImage.Create;

      try
        stream.LoadFromFile(path);
        jpg.LoadFromStream(stream);
      finally
        FreeAndNil(stream);
      end;

      bmp32 := TBitmap32.Create;
      try
        bmp32.Assign(jpg);
        strStr := TStringStream.Create('');
        bmp32.SaveToStream(strStr);
        strStr.Seek(0,soFromBeginning);
      finally
        FreeAndNil(jpg);
        FreeAndNil(bmp32);
      end;

      result := strStr.DataString;
      FreeAndNil(strStr);
    except
      on e: exception do
      begin
        err := e.Message;
        showmessage (err);
      end;
    end;
  end;

begin
  sciezka := 'd:\pictures\';

  for I := 1 to 100 do
  begin
    Path := IncludeTrailingPathDelimiter(sciezka) ;
    if FindFirst (Path + '*.jpg', faAnyFile - faDirectory, Rec) = 0 then
    begin
      try
        repeat
          TestFile (Path + Rec.Name);
        until FindNext(Rec) <> 0;
      finally
        FindClose(Rec) ;
      end;
    end;
  end;

end;

{ TThreadSafeJpegImage }

procedure TThreadSafeJpegImage.Draw(ACanvas: TCanvas; const Rect: TRect);
begin
  Bitmap.Canvas.Lock;
  try
    inherited Draw(ACanvas, Rect);
  finally
    Bitmap.Canvas.Unlock;
  end;
end;

end.

Answer 1

Graphics32小组的一个人为我找到了解决方案。我们必须修改一些修复到gr32单元，如下所示：

1) In TBitmap32.AssignTo() replace

  DrawTo(Bmp.Canvas.Handle, 0, 0);

with

  Bmp.Canvas.Lock;
  try
    DrawTo(Bmp.Canvas.Handle, 0, 0);
  finally
    Bmp.Canvas.UnLock;
  end;

2) In TBitmap32.Assign() replace

  TGraphicAccess(Source).Draw(Canvas, MakeRect(0, 0, Width, Height));

with

  Canvas.Lock;
  try
    TGraphicAccess(Source).Draw(Canvas, MakeRect(0, 0, Width, Height));
  finally
    Canvas.UnLock;
  end;

Now it works!

Answer 2

不是100％肯定，如果我是妄想，请把我投票。

TThreadSafeJpegImage.Draw锁定画布。
在表单上移动鼠标时，会强制重绘，表单无法执行（因为您之前已经锁定了画布），这会导致返回错误。

更改Draw代码如下：

procedure TThreadSafeJpegImage.Draw(ACanvas: TCanvas; const Rect: TRect);
var
  OKToDraw: boolean;
begin 
  OKToDraw:= Bitmap.Canvas.TryLock;
  if OKTODraw then try
    inherited Draw(ACanvas, Rect);
  finally
    Bitmap.Canvas.Unlock;
  end; {if try}
end;

Delphi 7，当窗体上移动光标时，句柄无效:)

2 个答案: