Создаем Splash Screen на Delphi

Если при загрузке программы, показывается Splash Screen (это небольшое окно с картинкой), то к таким программам пользователи относятся лучше, чем программам, при запуске которых несколько секунд ничего не происходит.
В интернете есть много примеров изготовления Splash Screen-а в Delphi, однако обычно это квадратная форма с натянутой на ней картинкой.
Но у многих программ это не квадратная форма, а красивое окно со сглаженными краями.
Я пытался сделать такое окно с помощью регионов, но края были неровные и смотрелись неказисто.
Выходом стали «Слоистые окна» (LayeredWindow).

Был создан класс TSplash:
Create(Image:TPNGImage) создает экземпляр класса и загружает картинку,
Show показывает Splash, Close скрывает.

Процедура, преобразующая обычное окно в LayeredWindow:

procedure TSplash.ToLayeredWindow;
var BitMap:TBitMap;
    bf:TBlendFunction;
    BitmapSize: TSize;
    BitmapPos:Tpoint;
begin
  {создание правильной битовой карты}
  BitMap:=TBitMap.Create;
  CreatePremultipliedBitmap(Bitmap,FImage);
  {описание BlendFunction}
  with bf do
  begin
    BlendOp:=AC_SRC_OVER;
    BlendFlags:=0;
    AlphaFormat:=AC_SRC_ALPHA;
    SourceConstantAlpha:=255;
  end;
  {получаем размеры BitMap}
  BitmapSize.cx:=Bitmap.Width;
  BitmapSize.cy:=Bitmap.Height;
  {получаем координаты BitMap}
  BitmapPos.X:=0;
  BitmapPos.Y:=0;
  {слоистый стиль окна}
  SetWindowLong(SplashForm.Handle, GWL_EXSTYLE,
    GetWindowLong(SplashForm.Handle, GWL_EXSTYLE)+ WS_EX_LAYERED );
  {превращение окна в слоистое окно }
  UpdateLayeredWindow(
    SplashForm.Handle,
    0,
    nil,
    <hh user=BitmapSize>,
    bitmap.Canvas.Handle,
    <hh user=BitmapPos>,
    0,
    <hh user=bf>,
    ULW_ALPHA
  );
  BitMap.Free;
end;

процедура CreatePremultipliedBitmap преобразует TPNGImage в 32-х разрядный TBitMap, нужный функции UpdateLayeredWindow:

procedure CreatePremultipliedBitmap(DstBitMap:TBitmap;SrcPngImage:TPNGImage);
type
  TRGBTripleArray = ARRAY[Word] of TRGBTriple;
  pRGBTripleArray = ^TRGBTripleArray;
  TRGBAArray = array[Word] of TRGBQuad;
  PRGBAArray = ^TRGBAArray;
var x,y:integer;
    TripleAlpha:double;
    pColor:pRGBTripleArray;
    pAlpha:pbytearray;
    pBmp:pRGBAArray ;
begin
  DstBitMap.Height:= SrcPngImage.Height;
  DstBitMap.Width:= SrcPngImage.Width;
  DstBitMap.PixelFormat:=pf32bit;
  for y := 0 to SrcPngImage.Height-1 do
    begin
    pAlpha:=SrcPngImage.AlphaScanline[y];
    pColor:=SrcPngImage.Scanline[y];
    pBmp:=DstBitMap.ScanLine[y];
    for x := 0 to SrcPngImage.Width-1 do
      begin
        pBmp[x].rgbReserved:=pAlpha[x];
        // преобразуем в нужный формат
        TripleAlpha:=pBmp[x].rgbReserved / 255;
        pBmp[x].rgbBlue:=byte(trunc(pColor[x].rgbtBlue*TripleAlpha));
        pBmp[x].rgbGreen:=byte(trunc(pColor[x].rgbtGreen*TripleAlpha));
        pBmp[x].rgbRed:=byte(trunc(pColor[x].rgbtRed*TripleAlpha));
      end;
    end;
end;

В качестве изображения используется экземпляр класса TPNGImage, что позволяет создавать полупрозрачные Splash Screen-ы.
Результат работы:

Полный код модуля:

unit SplashScreen;

interface
uses Windows,PNGImage,Forms,Graphics;
type
  TSplashForm=TForm;
  TSplash=class
    private
      FImage:TPNGImage;
      SplashForm:TSplashForm;
      procedure SetImage(value:TPNGImage);
      procedure ToLayeredWindow;
    public
      constructor Create;overload;
      constructor Create(Image:TPNGImage);overload;
      destructor Destroy;
      procedure Show;
      procedure Close;
      property Image:TPNGImage read FImage write SetImage;
  end;

implementation

procedure CreatePremultipliedBitmap(DstBitMap:TBitmap;SrcPngImage:TPNGImage);
type
  TRGBTripleArray = ARRAY[Word] of TRGBTriple;
  pRGBTripleArray = ^TRGBTripleArray;
  TRGBAArray = array[Word] of TRGBQuad;
  PRGBAArray = ^TRGBAArray;
var x,y:integer;
    TripleAlpha:double;
    pColor:pRGBTripleArray;
    pAlpha:pbytearray;
    pBmp:pRGBAArray ;
begin
  DstBitMap.Height:= SrcPngImage.Height;
  DstBitMap.Width:= SrcPngImage.Width;
  DstBitMap.PixelFormat:=pf32bit;
  for y := 0 to SrcPngImage.Height-1 do
    begin
    pAlpha:=SrcPngImage.AlphaScanline[y];
    pColor:=SrcPngImage.Scanline[y];
    pBmp:=DstBitMap.ScanLine[y];
    for x := 0 to SrcPngImage.Width-1 do
      begin
        pBmp[x].rgbReserved:=pAlpha[x];
        // преобразуем в нужный формат
        TripleAlpha:=pBmp[x].rgbReserved / 255;
        pBmp[x].rgbBlue:=byte(trunc(pColor[x].rgbtBlue*TripleAlpha));
        pBmp[x].rgbGreen:=byte(trunc(pColor[x].rgbtGreen*TripleAlpha));
        pBmp[x].rgbRed:=byte(trunc(pColor[x].rgbtRed*TripleAlpha));
      end;
    end;
end;

constructor TSplash.Create;
begin
  SplashForm:=TSplashForm.Create(nil);
  FImage:=TPNGImage.Create;
end;

constructor TSplash.Create(Image:TPNGImage);
begin
  SplashForm:=TForm.Create(nil);
  FImage:=TPNGImage.Create;
  FImage.Assign(Image);
end;

destructor TSplash.Destroy;
begin
  SplashForm.Free;
  FImage.Free
end;

procedure TSplash.SetImage(value:TPNGImage);
begin
  FImage.Assign(value);
end;

procedure TSplash.ToLayeredWindow;
var BitMap:TBitMap;
    bf:TBlendFunction;
    BitmapSize: TSize;
    BitmapPos:Tpoint;
begin
  {создание правильной битовой карты}
  BitMap:=TBitMap.Create;
  CreatePremultipliedBitmap(Bitmap,FImage);
  {описание BlendFunction}
  with bf do
  begin
    BlendOp:=AC_SRC_OVER;
    BlendFlags:=0;
    AlphaFormat:=AC_SRC_ALPHA;
    SourceConstantAlpha:=255;
  end;
  {получаем размеры BitMap}
  BitmapSize.cx:=Bitmap.Width;
  BitmapSize.cy:=Bitmap.Height;
  {получаем координаты BitMap}
  BitmapPos.X:=0;
  BitmapPos.Y:=0;
  {Слоистый стиль окна}
  SetWindowLong(SplashForm.Handle, GWL_EXSTYLE,
    GetWindowLong(SplashForm.Handle, GWL_EXSTYLE)+ WS_EX_LAYERED );
  {превращение окна в слоистое окно }
  UpdateLayeredWindow(
    SplashForm.Handle,
    0,
    nil,//pos
    <hh user=BitmapSize>,//size
    bitmap.Canvas.Handle,//src
    <hh user=BitmapPos>,//pptsrc
    0,
    <hh user=bf>,
    ULW_ALPHA
  );
  BitMap.Free;
end;

procedure TSplash.Show;
begin
  {создаем окно с нужными параметрами}
  with SplashForm do
  begin
    BorderStyle:=bsNone;
    width:=FImage.Width;
    Height:=FImage.Height;
    position:=poDesktopCenter;
    formstyle:=fsStayOnTop;
  end;
  {делаем из него слоистое окно}
  ToLayeredWindow;
  {показываем}
  SplashForm.Show;
end;

procedure TSplash.Close;
begin
  {прячем}
  SplashForm.Close;
end;

end.

Модуль предназначен для Delphi XE и выше.
Скачать модуль и пример использования можно здесь:
narod.ru/disk/53141368001.fe922942bf8a27383ef5e06f3963ae8d/TSplash.rar.html
Надеюсь, данный модуль сделает ваши приложения более привлекательными для пользователя.

Автор: Error1024