страничка tripsin'а

Окно с переменной прозрачностью

В сети валяется полно примеров, как сделать прозрачное окно с помощью функций SetLayeredWindowAttributes и UpdateLayeredWindow, но я не нашел ни одного вразумительного примера на Delphi, который делает окно с переменной прозрачностью. Поэтому выкладываю свой.
Для этого понадобится картинка с 32-битным цветом (с альфа-каналом). Я- сделал в Gimp'е простенький рисунок с полупрозрачным градиентом и сохранил его в формате PNG. Эту картинку загружаю в память и копирую ее в совместимый с экраном контекст. Функция UpdateLayeredWindow будет прорисовывать окно на основе этого контекста. Вот что получилось:

Совсем необязательно использовать для загрузки картинки сторонние компоненты. Вполне можно попользовать GDI+. Заголовочные файлы GDI+ можно закачать здесь же. Кроме всего прочего GDI+ при загрузке по умолчанию преобразует цветовые компоненты каждого пиксела для работы с прозрачностью и не надо вычислять их ручками по формулам. А размер файла вырастает не сильно - примерно на 25кб (минимум).
Привожу примитивный код который выводит на экран окошко с переменной прозрачностью на основе PNG-картинки (32 бит с альфа каналом). Окошко можно таскать мышой за шиворот. Компоненты на этой форме естественно не прорисуются. Это надо делать по другому. Код откомментирован. Вчитывайся :) Демонстрационный проект прилагается.

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormDblClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  end;

var
  Form1: TForm1;
  last_pos: TPoint;
  hbmp: HBITMAP; // Прозрачная картинка
  backdc: HDC; // Контекст для прозрачной картинки

implementation

{$R *.dfm}

uses GDIPAPI, GDIPOBJ; // Юзаем GDI+ !!!

procedure TForm1.FormCreate(Sender: TObject);
var
  img: TGPBitmap;
  screendc: HDC;
  pt1, pt2 : TPoint;
  sz : TSize;
  bf : TBlendFunction;
begin
  // Убираем рамку окна. Иначе ничего не выйдет.
  Self.BorderStyle := bsNone;
  // Делаем окно многослойным
  if SetWindowLong(Handle, GWL_EXSTYLE, GetWindowLong(Handle, GWL_EXSTYLE) or
  WS_EX_LAYERED) = 0 then ShowMessage(SysErrorMessage(GetLastError));
  // Загружаем 32-битный PNG с альфа каналом и получаем его HBITMAP
  img := TGPBitmap.Create('bluesquare.png',True);
  with img do begin
    GetHBITMAP(0,hbmp);
    Width := GetWidth;
    Height := GetHeight;
    Free;
  end;
  // Получаем контекст экрана 
  screendc := GetDC(0);
  // Создаем контекст, совместимый с экраном
  backdc := CreateCompatibleDC(screendc);
  // Загружаем в него картинку
  SelectObject(backdc, hbmp);
  // Вызываем UpdateLayeredWindow
  pt1 := Point(Left, Top);
  pt2 := Point(0,0);
  sz.cx := Width;
  sz.cy := Height;
  with bf do begin
    BlendOp := AC_SRC_OVER;
    BlendFlags := 0;
    SourceConstantAlpha := $FF; // Можно ставить общую прозрачность
    AlphaFormat := AC_SRC_ALPHA;
  end;
  UpdateLayeredWindow(Handle, screendc, @pt1, @sz, backdc, @pt2,0, @bf,ULW_ALPHA);
  // Освобождаем контекст экрана
  ReleaseDC(0,screendc);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  // Освобождаем ресурсы
  DeleteObject(hbmp);
  DeleteDC(backdc);
end;

// Дальше 2 обработчика нужны, чтобы двигать мышкой форму без заголовка
procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var
  cur_pos: TPoint;
begin
  if ssLeft in Shift then
  begin
    GetCursorPos(cur_pos);
    Left := cur_pos.X - last_pos.X;
    Top := cur_pos.Y - last_pos.Y;
  end;
end;

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  last_pos.X := X;
  last_pos.Y := Y;
end;

// Закрываем прогу по двойному клику в окошке
procedure TForm1.FormDblClick(Sender: TObject);
begin
  Close;
end;

end.