Visit my main Delphi page here

This small example demonstrates how to use Vista's new animated theme API to render an animated control. Requires Windows Vista and ThemesEx.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  ThemesEx;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  end;

var

  Form1: TForm1;

implementation

{$R *.dfm}

type
  TThemeWindow = class(TCustomControl)
  private
    FAnimatedHot: Boolean;
    FCurrentHot: Boolean;
    procedure CMMouseEnter(var Msg: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Msg: TMessage); message CM_MOUSELEAVE;
    procedure DrawWindow(DC: HDC; State: Boolean);
  protected

    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure TThemeWindow.CMMouseEnter(var Msg: TMessage);

begin
  inherited;
  FAnimatedHot := True;
  Repaint;
end;

procedure TThemeWindow.CMMouseLeave(var Msg: TMessage);
begin
  inherited;
  FAnimatedHot := False;
  Repaint;
end;


constructor TThemeWindow.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ControlStyle := ControlStyle + [csCaptureMouse];
  Width := 32;
  Height := 32;
end;

procedure TThemeWindow.DrawWindow(DC: HDC; State: Boolean);

var
  R: TRect;
  B: HBRUSH;
  I: HICON;
begin
  R := GetClientRect;
  B := CreateSolidBrush(ColorToRGB(Color));
  FillRect(DC, R, B);
  DeleteObject(B);
  if State then
    I := LoadIcon(0, IDI_QUESTION)
  else
    I := LoadIcon(0, IDI_ERROR);
  if I <> 0 then

  begin
    DrawIcon(DC, 0, 0, I);
    DestroyIcon(I);
  end;
end;

procedure TThemeWindow.Paint;
var
  DC, FromDC, ToDC: HDC;
  P: TBPAnimationParams;
  A: HANIMATIONBUFFER;

begin
  DC := Canvas.Handle;
  if not BufferedPaintRenderAnimation(Handle, DC) then
  begin
    FillChar(P, SizeOf(P), #0);
    P.cbSize := SizeOf(P);
    P.style := BPAS_LINEAR;
    if FCurrentHot <> FAnimatedHot then

      P.dwDuration := 500;
    A := BeginBufferedAnimation(Handle, DC, ClientRect,
      BPBF_COMPATIBLEBITMAP, nil, P, FromDC, ToDC);
    if A <> 0 then
    begin
      if FromDC <> 0 then

        DrawWindow(FromDC, FCurrentHot);
      if ToDC <> 0 then
        DrawWindow(ToDC, FAnimatedHot);
      FCurrentHot := FAnimatedHot;
      EndBufferedAnimation(A, True);
    end
    else
      DrawWindow(DC, FCurrentHot);
  end;

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  with TThemeWindow.Create(Self) do
  begin
    Parent := Self;
    Top := Self.ClientHeight - Height - 8;
    Left := Self.ClientWidth - Width - 8;
    Anchors := [akRight, akBottom];
  end;

end;

end.