Показывать индикатор активности, пока основной поток заблокирован (продолжить)

Question

Продолжить с предыдущий вопрос Я хочу показать какой-либо индикатор активности , даже если основной поток заблокирован .(на основе этой статьи ).

Проблемы, связанные с приложенным кодом:

• Использование Synchronize(PaintTargetWindow); не рисует окно
• Иногда я получаю сообщение об ошибке: Canvas does not allow drawing. В строке: {FBitmap.}StretchDraw(Rect(Left, ImageRect.Top, Right, ImageRect.Bottom), FfgPattern)

вот код, который я использую для создания потока индикатора:

unit AniThread;

interface

uses Windows, Classes, Graphics, Controls, Math;

const
  ANI_GRAD_FG_COLOR_BAGIN = $00CDFFCD;
  ANI_GRAD_FG_COLOR_END   = $0024B105;
  ANI_GRAD_BK_COLOR_BAGIN = $00F5F5F5;
  ANI_GRAD_BK_COLOR_END   = $00BDBDBD;

type
  TAnimationThread = class(TThread)
  private
    FWnd: HWND;
    FPaintRect: TRect;
    FInterval: Integer;
    FfgPattern, FbkPattern: TBitmap;
    FBitmap: TBitmap;
    FImageRect: TRect;
    procedure UpdatePattern(Pattern: TBitmap; ColorBegin, ColorEnd: TColor);
    function CreatePatternBitmap(AColorBegin, AColorEnd: TColor): TBitmap;
    procedure PaintTargetWindow;
  protected
    procedure Execute; override;
  public
    procedure Animate;
    constructor Create(PaintSurface: TWinControl; { Control to paint on }
      PaintRect: TRect;          { area for animation bar }
      Interval: Integer          { wait in msecs between paints}
      );
    destructor Destroy; override;
  end;

implementation

constructor TAnimationThread.Create(PaintSurface: TWinControl;
  PaintRect: TRect;
  Interval: Integer);
begin
  inherited Create(True); { suspended }
  FreeOnterminate := True;
  Priority := tpHigher;
  FInterval := Interval;
  FWnd := PaintSurface.Handle;
  FPaintRect := PaintRect;
  FfgPattern := CreatePatternBitmap(ANI_GRAD_FG_COLOR_BAGIN, ANI_GRAD_FG_COLOR_END);
  FbkPattern := CreatePatternBitmap(ANI_GRAD_BK_COLOR_BAGIN, ANI_GRAD_BK_COLOR_END);
end;

destructor TAnimationThread.Destroy;
begin
  inherited Destroy;
  FfgPattern.Free;
  FbkPattern.Free;
end;

procedure TAnimationThread.Animate;
begin
  Resume;
  Sleep(0);
end;

function TAnimationThread.CreatePatternBitmap(AColorBegin, AColorEnd: TColor): TBitmap;
begin
  Result := TBitmap.Create;
  Result.PixelFormat := pf24bit;
  UpdatePattern(Result, AColorBegin, AColorEnd);
end;

type
  PRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array[0..32767] of TRGBTriple;
  TGradientColors = array[0..255] of TRGBTriple;

procedure PatternBuilder(const Colors: TGradientColors; Pattern: TBitmap);
var
  Y: Integer;
  Row: PRGBTripleArray;
begin
  Pattern.Width := 1;
  Pattern.Height := 256;
  for Y := 0 to 127 do
  begin
    Row := PRGBTripleArray(Pattern.ScanLine[Y]);
    Row[0] := Colors[Y];
    Row := PRGBTripleArray(Pattern.ScanLine[Y + 128]);
    Row[0] := Colors[255 - Y];
  end;
end;

procedure TAnimationThread.UpdatePattern(Pattern: TBitmap; ColorBegin, ColorEnd: TColor);
var
  Colors: TGradientColors;
  dRed, dGreen, dBlue: Integer;
  RGBColor1, RGBColor2: TColor;
  RGB1, RGB2: TRGBTriple;
  Index: Integer;
begin
  RGBColor1 := ColorToRGB(ColorBegin);
  RGBColor2 := ColorToRGB(ColorEnd);

  RGB1.rgbtRed := GetRValue(RGBColor1);
  RGB1.rgbtGreen := GetGValue(RGBColor1);
  RGB1.rgbtBlue := GetBValue(RGBColor1);

  RGB2.rgbtRed := GetRValue(RGBColor2);
  RGB2.rgbtGreen := GetGValue(RGBColor2);
  RGB2.rgbtBlue := GetBValue(RGBColor2);

  dRed := RGB2.rgbtRed - RGB1.rgbtRed;
  dGreen := RGB2.rgbtGreen - RGB1.rgbtGreen;
  dBlue := RGB2.rgbtBlue - RGB1.rgbtBlue;

  for Index := 0 to 255 do
    with Colors[Index] do
    begin
      rgbtRed := RGB1.rgbtRed + (Index * dRed) div 255;
      rgbtGreen := RGB1.rgbtGreen + (Index * dGreen) div 255;
      rgbtBlue := RGB1.rgbtBlue + (Index * dBlue) div 255;
    end;

  PatternBuilder(Colors, Pattern);
end;

procedure TAnimationThread.PaintTargetWindow;
var
  DC: HDC;
begin
  DC := GetDC(FWnd);
  if DC <> 0 then
    try
      BitBlt(DC,
        FPaintRect.Left,
        FPaintRect.Top,
        FImageRect.Right,
        FImageRect.Bottom,
        FBitmap.Canvas.handle,
        0, 0,
        SRCCOPY);
    finally
      ReleaseDC(FWnd, DC);
    end;
end;

procedure TAnimationThread.Execute;
var
  Left, Right: Integer;
  Increment: Integer;
  State: (incRight, incLeft, decLeft, decRight);
begin
  InvalidateRect(FWnd, nil, True);
  FBitmap := TBitmap.Create;
  try
    with FBitmap do
    begin
      Width := FPaintRect.Right - FPaintRect.Left;
      Height := FPaintRect.Bottom - FPaintRect.Top;
      FImageRect := Rect(0, 0, Width, Height);
    end;
    Left := 0;
    Right := 0;
    Increment := FImageRect.Right div 50;
    State := Low(State);
    while not Terminated do
    begin
      with FBitmap.Canvas do
      begin
        StretchDraw(FImageRect, FbkPattern);
        case State of
          incRight:
            begin
              Inc(Right, Increment);
              if Right > FImageRect.Right then begin
                Right := FImageRect.Right;
                Inc(State);
              end;
            end;
          incLeft:
            begin
              Inc(Left, Increment);
              if Left >= Right then begin
                Left := Right;
                Inc(State);
              end;
            end;
          decLeft:
            begin
              Dec(Left, Increment);
              if Left <= 0 then begin
                Left := 0;
                Inc(State);
              end;
            end;
          decRight:
            begin
              Dec(Right, Increment);
              if Right <= 0 then begin
                Right := 0;
                State := incRight;
              end;
            end;
        end;

        StretchDraw(Rect(Left, FImageRect.Top, Right, FImageRect.Bottom), FfgPattern);
      end; { with }

      // Synchronize(PaintTargetWindow); // not painting when the main thread is blocked
      PaintTargetWindow;

      SleepEx(FInterval, False);
    end; { While }
  finally
    FBitmap.Free;
  end;
end;

end.

Использование: сбросить TButton и TPanel в главной форме.

uses AniThread;

procedure TForm1.Button1Click(Sender: TObject);
var
  at: TAnimationThread;
begin
  at := TAnimationThread.Create(Panel1, Panel1.ClientRect, 10);
  Button1.Enabled := False;
  try
    at.Animate;
    Sleep(3000); // sleep 3 sec. block main thread
  finally
    at.Terminate;
    Button1.Enabled := True;
  end;
end;

Я знаю, что многие из вас не одобрят такой подход.Но сейчас мне в основном сложно сделать так, чтобы это работало хорошо.Любая помощь в этом вопросе будет высоко оценена.

РЕДАКТИРОВАТЬ:

Это оригинальная статья (Питер Белоу, TeamB).Я реализовал только градиентную живопись.

Answer 1

Canvas does not allow drawing. Исключение В строке:

FBitmap.StretchDraw(Rect(Left, ImageRect.Top, Right, ImageRect.Bottom), FfgPattern)

Это связано с тем, что TBitmap canvas не является потокобезопасным , если не заблокирован (даже в основном потоке пользовательского интерфейса). По моему опыту, даже если вы заблокируете холст в рабочем потоке, его DC может быть освобожден с помощью Graphics.pas Кэширование сборки мусора / GDI, в то время как сообщения обрабатываются в основном пользовательском интерфейсе TWinControl.MainWndProc. Каждое растровое полотно, к которому обращаются, должно быть заблокировано, включая FBitmap + FbkPattern + FfgPattern в моем коде.

См. FreeMemoryContexts в Graphis.pas:

{ FreeMemoryContexts is called by the VCL main winproc to release
  memory DCs after every message is processed (garbage collection).
  Only memory DCs not locked by other threads will be freed.
}

Возможное решение - НЕ использовать TBitmap.Canvas напрямую и использовать CreateCompatibleDC, как описано здесь: Как загрузить изображения с диска в фоновом режиме (несколько потоков) [AKA: TBitmap не является поточно-ориентированным] * или заблокируйте каждый TCanvas, который вы используете.

Дополнительные ссылки:
Насколько потокобезопасен TBitmap
GDI обрабатывает утечку с использованием TGIFImage во втором потоке
QC: TJPEGImage.Draw () не является потокобезопасным

---

Код, который работал для меня застрахован каждые TBitmap.Canvas, блокируется в контексте рабочего потока:
Рабочая TAnimationThread
Это работает независимо от того, заблокирован основной поток пользовательского интерфейса или нет.

procedure TForm1.Button1Click(Sender: TObject);
var
  at1, at2, at3, at4, at5: TAnimationThread;
begin
  at1 := TAnimationThread.Create(Panel1, Panel1.ClientRect, 10);
  at2 := TAnimationThread.Create(Panel2, Panel2.ClientRect, 10);
  at3 := TAnimationThread.Create(Panel3, Panel3.ClientRect, 10);
  at4 := TAnimationThread.Create(Panel4, Panel4.ClientRect, 10);
  at5 := TAnimationThread.Create(Panel5, Panel5.ClientRect, 10);
  // Sleep(5000); // do some work for 5 seconds, block main thread
  // at1.Terminate; at2.Terminate; at3.Terminate; at4.Terminate; at5.Terminate;
end;

Теперь, если я опущу, например, блокировку FfgPattern.Canvas.Lock;, DC TBitmap s будет убит, пока я перемещаю форму пользовательского интерфейса (в случае, когда я НЕ блокирую основной поток, т.е. не сплю в течение 5 секунд и не прерывая темы).

Мои выводы:

1. «Вы не можете рисовать на элементе управления VCL из чего-либо, кроме основного потока» (из комментариев). Не правда! Доступ к любому главному оконному контроллеру VCL можно получить из рабочего потока без каких-либо проблем (например, многие приложения перенаправляют непосредственно в окно рабочего стола DC).

2. TBitmap canvas является поточно-ориентированным, если вы знаете, где и когда его заблокировать.

3. Поскольку я не уверен, где и когда его заблокировать, лучше НЕ использовать TBitmap canvas в рабочем потоке. использовать манипуляции с растровыми изображениями API, использовать CreateCompatibleDC/CreateBitmap; TWICImage, стоящий поверх компонентов Windows Imaging. TBitmap Сборка мусора это зло!

4. Я не рекомендую этот метод. лучшим способом было бы создать чистое окно API в контексте рабочего потока и показать там индикатор активности, например, Отображение заставки в Delphi, когда основной поток занят

5. Лучший подход (как уже упоминалось в комментариях) - выполнять тяжелую работу в рабочем потоке и показывать индикатор активности в основном шаге пользовательского интерфейса во время работы рабочего потока.

Answer 2

Первоначально это всегда сбой.Затем я нашел решение:

1) Оберните цикл while внутри структуры try-finally с FBitmap.Canvas.Lock;:

FBitmap.Canvas.Lock;
try
  while not Terminated do
  begin
    with FBitmap.Canvas do
    begin
      StretchDraw(FImageRect, FbkPattern);
      case State of
        incRight:
          begin
            Inc(Right, Increment);
            if Right > FImageRect.Right then
            begin
              Right := FImageRect.Right;
              Inc(State);
            end;
          end;
        incLeft:
          begin
            Inc(Left, Increment);
            if Left >= Right then
            begin
              Left := Right;
              Inc(State);
            end;
          end;
        decLeft:
          begin
            Dec(Left, Increment);
            if Left <= 0 then
            begin
              Left := 0;
              Inc(State);
            end;
          end;
        decRight:
          begin
            Dec(Right, Increment);
            if Right <= 0 then
            begin
              Right := 0;
              State := incRight;
            end;
          end;
      end;

      StretchDraw(Rect(Left, FImageRect.Top, Right, FImageRect.Bottom), FfgPattern);
    end; { with }

    // Synchronize(PaintTargetWindow); // not painting when the main thread is blocked
    PaintTargetWindow;

    SleepEx(FInterval, False);
  end; { While }
finally
  FBitmap.Canvas.Unlock;
end;

2) В FormCreate вызова вашего приложенияэта процедура:

procedure DisableProcessWindowsGhosting;
var
  DisableProcessWindowsGhostingProc: procedure;
begin
  DisableProcessWindowsGhostingProc := GetProcAddress(GetModuleHandle('user32.dll'), 'DisableProcessWindowsGhosting');
  if Assigned(DisableProcessWindowsGhostingProc) then
    DisableProcessWindowsGhostingProc;
end;

Теперь все работает отлично - до сих пор не разбился!Delphi XE2, Win7 x64

Answer 3

Опять же, единственный потокобезопасный способ рисования в окне - это рисование из того же потока, который создал окно; все остальное небезопасно.

Как возможное объяснение того, почему ваш код хорошо работал со старыми версиями Windows и не работает с современными версиями, прочитайте эту статью Старая новая вещь .