procedure TForm1.FormCreate(Sender: TObject);
begin
 Bmp := Image1.Picture.Bitmap;
 with Bmp do
 begin
    width := 300;
    height := 300;
 end;
end;
 
procedure TForm1.DArc(CenterX, CenterY, Radius: Integer; AngleStart, AngleEnd: Double);
var
  X1, Y1, X2, Y2: Integer;
  X3, Y3, X4, Y4: Integer;
  RadStart, RadEnd: Double;
begin
  X1 := CenterX - Radius;
  Y1 := CenterY - Radius;
  X2 := CenterX + Radius;
  Y2 := CenterY + Radius;
 
  RadStart := AngleStart * Pi / 180;
  RadEnd   := AngleEnd * Pi / 180;
 
  X3 := CenterX + Round(Radius * Cos(RadStart));
  Y3 := CenterY + Round(Radius * Sin(RadStart));
 
  X4 := CenterX + Round(Radius * Cos(RadEnd));
  Y4 := CenterY + Round(Radius * Sin(RadEnd));
 
  Bmp.Canvas.Brush.Color := clWhite;
  Bmp.Canvas.FillRect(ClientRect);
  Bmp.Canvas.Pen.Color := clSkyBlue;
  Bmp.Canvas.Pen.Width := 10;
  Bmp.Canvas.Arc(X1, Y1, X2, Y2, X4, Y4, X3, Y3);
end;
 
 
var
 CPos, P2, total: integer;
 
procedure TForm1.Timer1Timer(Sender: TObject);
const
  N  = 30;
  N2 = N * 10 div 15;
  K1 = 180 div N2;
  K2 = 360 div N2;
  K3 = 90  div N2;
 
var
  Curr: Integer;
begin
 
  Curr := total mod N;
  Inc(total);
 
  if Curr = 0 then
  begin
    CPos := P2 - 2;
    Inc(P2, K1);
  end else if Curr < N2 then
  begin
    Inc(CPos, K1);
    Inc(P2, K2);
  end else
  begin
    Inc(CPos, K1 * 2);
    Inc(P2, K3);
  end;
 
  DArc(150, 150, 40, CPos mod 360, P2 mod 360);
end;

  Arc1.StartAngle := CPos;
  Arc1.EndAngle := P2 - CPos;

type
  TLayeredWindow = class abstract
  private
    type
      TLayeredWindowProc = reference to procedure(aControl: TWinControl; aCanvas: TD2DCanvas; aRect: TRect);
    class function DoDraw(aControl: TWinControl; aBmp: TBitmap; aRect: TRect; aProc: TLayeredWindowProc; aOptions: TLayeredOptions; aOpacity :byte) :boolean; inline;
    class function Resize(aBoundsRect: TRect; aImageRect: TRect; aOptions: TLayeredOptions): TRect; inline;
  public
    class function Draw(aControl: TWinControl; aProc: TLayeredWindowProc; aOptions: TLayeredOptions = []; aOpacity :byte = 255) :boolean; overload;
    class function Draw(aControl: TWinControl; aImage :TWICImage; aProc: TLayeredWindowProc = nil; aOptions: TLayeredOptions = []; aOpacity :byte = 255) :boolean; overload;
    {$IF CompilerVersion >= 34.0}
    class function Draw(aControl: TWinControl; aImageCollection :TImageCollection; aImageName: string; aProc: TLayeredWindowProc = nil; aOptions: TLayeredOptions = []; aOpacity :byte = 255) :boolean; overload;
    class function Draw(aControl: TWinControl; aImageCollection :TImageCollection; aImageIndex: integer; aProc: TLayeredWindowProc = nil; aOptions: TLayeredOptions = []; aOpacity :byte = 255) :boolean; overload;
    {$ENDIF}
    class function DrawFromFileName(aControl: TWinControl; const aFileName :string; aProc: TLayeredWindowProc = nil; aOptions: TLayeredOptions = []; aOpacity :byte = 255) :boolean;
    class function DrawFromResource(aControl: TWinControl; aInstance :THandle; const aResName :string; aProc: TLayeredWindowProc = nil; aOptions: TLayeredOptions = []; aOpacity :byte = 255) :boolean;
    class function DrawFromStream(aControl: TWinControl; aStream :TStream; aProc: TLayeredWindowProc = nil; aOptions: TLayeredOptions = []; aOpacity :byte = 255) :boolean;
  end;

 
procedure TForm1.FormCreate(Sender: TObject);
begin
  TLayeredWindow.DrawFromResource(Self, hInstance, 'SplashScreen', [loOpaque]);
end;

procedure TForm1.DrawNextStep(const aText: string);
begin
  TLayeredWindow.DrawFromResource(Self, hInstance, 'SplashScreen',
    procedure(aControl: TWinControl; aCanvas: TD2DCanvas; aRect: TRect)
    begin
      aCanvas.Font.Assign(Font);
      aCanvas.Brush.Style := bsClear;
      aCanvas.TextOut(ScaleValue(200), aRect.Bottom -ScaleValue(100), aText);
    end, [loOpaque]);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DrawNextStep('Chargement des bibliothèques...');
  // Action
  DrawNextStep('Initialisation...');
  // Action
  DrawNextStep('Démarrage...');
  // Action
end;

 
procedure TForm1.DrawOverlays(aControl: TWinControl);
begin
  TLayeredWindow.Draw(aControl, ImageCollection1, 'Delphi', nil, [], 30);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DrawOverlays(StaticText1);
  DrawOverlays(StaticText2);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  TLayeredWindow.DrawFromFileName(
    Panel1, 'D:\Delphi\Test\LayeredWindows\Car.webp',
    procedure(aControl: TWinControl; aCanvas: TD2DCanvas; aRect: TRect)
    var
      TextFormat: IDWriteTextFormat;
      TextLayout: IDWriteTextLayout;
      Brush: ID2D1SolidColorBrush;
    begin
      if Sold then
      begin
        const Matrix = TD2DMatrix3X2F.Rotation(-30, aRect.CenterPoint.X, aRect.CenterPoint.Y);
        aCanvas.RenderTarget.SetTransform(Matrix);
 
        DWriteFactory.CreateTextFormat('Tahoma', nil, DWRITE_FONT_WEIGHT_BOLD, DWRITE_FONT_STYLE_NORMAL, DWRITE_FONT_STRETCH_NORMAL, 60, 'fr', TextFormat);
        DWriteFactory.CreateTextLayout('Vendu', 5, TextFormat, aRect.Width, aRect.Height, TextLayout);
 
        TextLayout.SetTextAlignment(DWRITE_TEXT_ALIGNMENT_CENTER);
        TextLayout.SetParagraphAlignment(DWRITE_PARAGRAPH_ALIGNMENT_CENTER);
 
        aCanvas.RenderTarget.CreateSolidColorBrush(D2D1ColorF(clRed, 0.5), nil, Brush);
        aCanvas.RenderTarget.DrawTextLayout(D2D1PointF(0,0), TextLayout, Brush);
      end;
    end, [loProportional, loCenter]);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  TLayeredWindow.Draw(Panel1,
    procedure(aControl: TWinControl; aCanvas: TD2DCanvas; aRect: TRect)
    var
      Badge: ID2D1RoundedRectangleGeometry;
      Params: TD2D1LayerParameters;
      Layer: ID2D1Layer;
    begin
      const Image = ImageCollection1.GetSourceImage(2, aRect.Width, aRect.Height);
      const RoundedRect = D2D1RoundedRect(D2D1RectF(0, 0, aRect.Right, aRect.Bottom), aRect.Width/2, aRect.Height/2);
 
      D2DFactory.CreateRoundedRectangleGeometry(RoundedRect, Badge);
 
      Params.ContentBounds     := D2D1RectF(-INFINITE, -INFINITE, INFINITE, INFINITE);
      Params.geometricMask     := Badge;
      Params.MaskAntiAliasMode := D2D1_ANTIALIAS_MODE_PER_PRIMITIVE;
      Params.maskTransform     := TD2D1Matrix3X2F.Identity;
      Params.Opacity           := 1;
      Params.OpacityBrush      := nil;
      Params.LayerOptions      := D2D1_LAYER_OPTIONS_NONE;
 
      aCanvas.RenderTarget.CreateLayer(nil, Layer);
      aCanvas.RenderTarget.PushLayer(Params, Layer);
 
      aCanvas.StretchDraw(aRect, Image);
      aCanvas.Brush.Style := bsClear;
      aCanvas.Ellipse(aRect);
 
      aCanvas.RenderTarget.PopLayer;
    end);
end;

type
  TCheckBox = class(Vcl.StdCtrls.TCheckBox)
  protected
    procedure CreateWnd; override;
    procedure Paint;
    procedure WndProc(var Message: TMessage); override;
  end;
 
{ TCheckBox }
 
procedure TCheckBox.CreateWnd;
begin
  inherited;
  Paint;
end;
 
procedure TCheckBox.Paint;
begin
  TLayeredWindow.Draw(Self,
    procedure(aControl: TWinControl; aCanvas: TD2DCanvas; aRect: TRect)
    var
      Brush: ID2D1SolidColorBrush;
    begin
      var Text := IfThen(Checked, '👍', '👎') +Caption;
 
      // Fond "presque" transparent pour que le texte soit cliquable (entre les lettres)
      aCanvas.RenderTarget.CreateSolidColorBrush(D2D1ColorF(clNone, 0.01), nil, Brush);
      aCanvas.RenderTarget.FillRectangle(D2D1RectF(0, 0, aRect.Right, aRect.Bottom), Brush);
 
      aCanvas.Font.Assign(Font);
      aCanvas.Font.Color := IfThen(Checked, clHighlight, clBlack);
      aCanvas.Brush.Style := bsClear;
      aCanvas.TextRect(aRect, Text, [tfVerticalCenter, tfSingleLine]);
 
      if Focused then
      begin
        aCanvas.Pen.Color := clBlack;
        aCanvas.Pen.Style := psDot;
        SystemParametersInfo(SPI_GETFOCUSBORDERWIDTH, 0, @aCanvas.Pen.Width, 0);
        aCanvas.Rectangle(aRect);
      end;
    end, [loProportional, loOpaque]);
end;
 
procedure TCheckBox.WndProc(var Message: TMessage);
begin
  inherited;
 
  if (Message.Msg = CM_CHANGED) or
     (Message.Msg = WM_SetFocus) or
     (Message.Msg = WM_KillFocus) then Paint;
end;

uses System.TypInfo, Generics.Defaults;
 
type
  TWakeType = (wtSingle, wtAll);
  TWakeCompare = (wcEqual, wcNotEqual, wcBelow, wcAbove, wcIn, wcOut, wcCustom);
 
  TWakeValue<T> = record
  private type
    TWakeCompareProc = reference to function(const aValue: T) :boolean;
  private
    FCompareValue: T;
    FAutoReset: boolean;
    FValue: T;
    FWakeType: TWakeType;
    Lock: TObject;
    procedure SetValue(const aValue: T);
    function GetValue: T;
    procedure CheckIsOrdinal; inline;
    procedure Normalize(var aLowerValue, aUpperValue: T);
    function DoWait(const aValue1, aValue2: T; aCompare: TWakeCompare; aCompareProc: TWakeCompareProc; aTimeOut: cardinal): boolean;
  public
    property Value :T read GetValue write SetValue;
    class operator Initialize(out Dest: TWakeValue<T>);
    class operator finalize(var Dest: TWakeValue<T>);
    class operator Assign(var Dest: TWakeValue<T>; const [ref] Source: TWakeValue<T>);
    function Wait(aTimeout :cardinal = INFINITE) :boolean; overload;
    function Wait(aCompareProc: TWakeCompareProc; aTimeout :cardinal = INFINITE) :boolean; overload;
    function WaitEquals(const aWaitValue: T; aTimeout :cardinal = INFINITE) :boolean;
    function WaitBelow(const aBelowValue: T; aTimeout :cardinal = INFINITE) :boolean;
    function WaitAbove(const aAboveValue: T; aTimeout :cardinal = INFINITE) :boolean;
    function WaitIn(aLowerValue, aUpperValue: T; aTimeout :cardinal = INFINITE) :boolean;
    function WaitOut(aLowerValue, aUpperValue: T; aTimeout :cardinal = INFINITE) :boolean;
    constructor Create(const aValue, aCompareValue :T; aAutoReset: boolean = TRUE; aWakeType :TWakeType = wtAll); overload;
    constructor Create(const aValue :T; aAutoReset: boolean = TRUE; aWakeType :TWakeType = wtAll); overload;
  end;
 
{ TWakeValue<T> }
 
class operator TWakeValue<T>.Initialize(out Dest: TWakeValue<T>);
begin
  Assert(SizeOf(T) <= 8, 'SizeOf(T) exceeds 8');
 
  Dest.FValue := Default(T);
  Dest.FCompareValue := Default(T);
  Dest.FAutoReset := TRUE;
  Dest.FWakeType := wtAll;
  Dest.Lock := TObject.Create;
end;
 
class operator TWakeValue<T>.finalize(var Dest: TWakeValue<T>);
begin
  Dest.Lock.Free;
end;
 
class operator TWakeValue<T>.Assign(var Dest: TWakeValue<T>; const [ref] Source: TWakeValue<T>);
begin
  TMonitor.Enter(Source.Lock);
  TMonitor.Enter(Dest.Lock);
  try
    Dest.FCompareValue := Source.FCompareValue;
    Dest.FValue := Source.FValue;
    Dest.FWakeType := Source.FWakeType;
    Dest.FAutoReset := Source.FAutoReset;
  finally
    TMonitor.Exit(Source.Lock);
    TMonitor.Exit(Dest.Lock);
  end;
end;
 
constructor TWakeValue<T>.Create(const aValue, aCompareValue: T; aAutoReset: boolean; aWakeType: TWakeType);
begin
  FCompareValue := aCompareValue;
  FAutoReset := aAutoReset;
  FWakeType := aWakeType;
 
  SetValue(aValue);
end;
 
constructor TWakeValue<T>.Create(const aValue: T; aAutoReset: boolean; aWakeType: TWakeType);
begin
  Create(aValue, aValue, aAutoReset, aWakeType);
end;
 
procedure TWakeValue<T>.Normalize(var aLowerValue, aUpperValue: T);
begin
  if TComparer<T>.Default.Compare(aLowerValue, aUpperValue) > 0 then
  begin
    const Tmp = aUpperValue;
    aUpperValue := aLowerValue;
    aLowerValue := Tmp;
  end;
end;
 
procedure TWakeValue<T>.CheckIsOrdinal;
begin
  Assert(PTypeInfo(TypeInfo(T))^.Kind in [tkInteger, tkInt64, tkFloat, tkChar, tkWChar, tkEnumeration], '<T> is not a valid type (numeric, char or enumeration)');
end;
 
function TWakeValue<T>.GetValue: T;
begin
  TMonitor.Enter(Lock);
  try
    Result := FValue;
  finally
    TMonitor.Exit(Lock);
  end;
end;
 
procedure TWakeValue<T>.SetValue(const aValue: T);
begin
  TMonitor.Enter(Lock);
  try
    if not TEqualityComparer<T>.Default.Equals(FValue, aValue) then
    begin
      FValue := aValue;
 
      if not TEqualityComparer<T>.Default.Equals(FValue, FCompareValue) then
      begin
        case FWakeType of
          wtSingle : WakeByAddressSingle(@FValue);
          wtAll    : WakeByAddressAll(@FValue);
        end;
 
        if FAutoReset then
          FCompareValue := FValue;
      end;
    end;
 
  finally
    TMonitor.Exit(Lock);
  end;
end;
 
function TWakeValue<T>.DoWait(const aValue1, aValue2: T; aCompare: TWakeCompare; aCompareProc: TWakeCompareProc; aTimeOut: cardinal): boolean;
begin
  while TRUE do
  begin
    const Value = GetValue;
    const Res = TComparer<T>.Default.Compare(Value, aValue1);
 
    case aCompare of
      wcEqual    : if Res = 0 then Exit(TRUE);
      wcNotEqual : if Res <> 0 then Exit(TRUE);
      wcBelow    : if Res < 0 then Exit(TRUE);
      wcAbove    : if Res > 0 then Exit(TRUE);
      wcIn       : if (Res >= 0) and (TComparer<T>.Default.Compare(Value, aValue2) <= 0) then Exit(TRUE);
      wcOut      : if (Res < 0) or (TComparer<T>.Default.Compare(Value, aValue2) > 0) then Exit(TRUE);
      wcCustom   : if aCompareProc(Value) then Exit(TRUE);
    end;
 
    if not WaitOnAddress(@FValue, @FValue, SizeOf(T), aTimeout) then Exit(FALSE);
  end;
end;
 
function TWakeValue<T>.WaitEquals(const aWaitValue: T; aTimeout: cardinal): boolean;
begin
  Result := DoWait(aWaitValue, Default(T), wcEqual, nil, aTimeOut);
end;
 
function TWakeValue<T>.WaitAbove(const aAboveValue: T; aTimeout: cardinal): boolean;
begin
  CheckIsOrdinal;
  Result := DoWait(aAboveValue, Default(T), wcAbove, nil, aTimeOut);
end;
 
function TWakeValue<T>.WaitBelow(const aBelowValue: T; aTimeout: cardinal): boolean;
begin
  CheckIsOrdinal;
  Result := DoWait(aBelowValue, Default(T), wcBelow, nil, aTimeOut);
end;
 
function TWakeValue<T>.WaitIn(aLowerValue, aUpperValue: T; aTimeout: cardinal): boolean;
begin
  CheckIsOrdinal;
  Normalize(aLowerValue, aUpperValue);
  Result := DoWait(aLowerValue, aUpperValue, wcIn, nil, aTimeOut);
end;
 
function TWakeValue<T>.WaitOut(aLowerValue, aUpperValue: T; aTimeout: cardinal): boolean;
begin
  CheckIsOrdinal;
  Normalize(aLowerValue, aUpperValue);
  Result := DoWait(aLowerValue, aUpperValue, wcOut, nil, aTimeOut);
end;
 
function TWakeValue<T>.Wait(aTimeout: cardinal): boolean;
var
  CompareValue: T;
begin
  TMonitor.Enter(Lock);
  try
    CompareValue := FCompareValue;
  finally
    TMonitor.Exit(Lock);
  end;
 
  Result := DoWait(CompareValue, Default(T), wcNotEqual, nil, aTimeOut);
end;
 
function TWakeValue<T>.Wait(aCompareProc: TWakeCompareProc; aTimeout :cardinal) :boolean;
begin
  Assert(Assigned(aCompareProc), 'aCompareProc cannot be nil.');
  Result := DoWait(Default(T), Default(T), wcCustom, aCompareProc, aTimeOut);
end;

var
  StatusMsg :TWakeValue<string>;
  SafeOperation :TWakeValue<integer>;
  ErrorMsg :TWakeValue<string>;
 
TMyThread1.Execute;
begin
  StatusMsg.WaitEquals('Success');
  ...
end;
 
TMyThread2.Execute;
begin
  SafeOperation.WaitIn(50, 60);
  ...
end;
 
TMyThread3.Execute;
begin
  ErrorMsg.Wait(function(const aValue: string): boolean
                begin
                  Result := aValue.StartsWith('Error');
                end);
  ...
end;
 
StatusMsg.Value := 'Success';
SafeOperation.Value := 55;
ErrorMsg.Value := 'Error 200';