Show activity indicator while the main thread is blocked

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}
      CreateSuspended: Boolean=False);
    destructor Destroy; override;
  end;

implementation

constructor TAnimationThread.Create(
  PaintSurface: TWinControl;
  PaintRect: TRect;
  Interval: Integer;
  CreateSuspended: Boolean);
begin
  FreeOnterminate := True;
  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);
  FBitmap := TBitmap.Create;
  inherited Create(CreateSuspended);
  Priority := tpHigher;
end;

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

procedure TAnimationThread.Animate;
begin
  if Suspended then
  begin
    Resume;
    Sleep(0);
  end;
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
  Pattern.Canvas.Lock;
  try
    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);
  finally
    Pattern.Canvas.Unlock;
  end;
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
  FBitmap.Canvas.Lock;
  FbkPattern.Canvas.Lock;
  FfgPattern.Canvas.Lock;
  try
    InvalidateRect(FWnd, nil, True);
    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 FBitmap.Canvas }

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

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

end.