unit AlphaBlending;

interface

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

type
  TfmAlphaBlending = class(TForm)
    procedure FormPaint(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure DrawAlphaBlend(hWnd: HWND; hdcwnd: HDC);
  end;

var
  fmAlphaBlending: TfmAlphaBlending;

implementation

{$R *.dfm}

{ TfmAlphaBlending }

procedure TfmAlphaBlending.DrawAlphaBlend(hWnd: HWND; hdcwnd: HDC);
var
  hCurDC: HDC;       // описатеть контекста устройства, который мы создадим
  bf: BLENDFUNCTION; // запись альфа-смешивания
  hbmp: HBITMAP;     // дескриптор точечного рисунка
  bmi: BITMAPINFO;   // заголовок точечного рисунка
  pvBits: Pointer;   // pointer to DIB section
  ulWindowWidth, ulWindowHeight: ULONG;  // ширина/высота клиентской области
  ulBitmapWidth, ulBitmapHeight: ULONG;  // ширина/высота точечного рисунка
  rt: TRect;       // используется для получения размером клиентоской области
  x,y: Integer;    // циклические переменные
  ubAlpha: UCHAR;  // используется чтобы делать прозрачный градиент
  ubRed: UCHAR;
  ubGreen: UCHAR;
  ubBlue: UCHAR;
  fAlphaFactor: Real;
  r, g, b: UCHAR;
begin
  // получаем размеры клиентоской области
  Windows.GetClientRect(hWnd, rt);
  // расчитываем ширину и высоту клиентской области
  ulWindowWidth := rt.right - rt.left;
  ulWindowHeight := rt.bottom - rt.top;
  if (ulWindowWidth = 0) or (ulWindowHeight = 0) then
    Exit;
  // делим окно на три горизонтальные области
  ulWindowHeight := ulWindowHeight div 3;
  // создаем контекст устройства для нашего точечного рисунка
  hCurDC := CreateCompatibleDC(hdcwnd);
  ZeroMemory(@bmi, sizeof(BITMAPINFO));
  // устанавливаем параметры точечного рисунка
  // указываем ширину и высоту 60% ширины для точечного рисунка и
  // высоты каждой из трех горизонтальных областей. Позже, осуществим
  // смешивание в центре каждой из этих трех областей.
  with bmi.bmiHeader do
    begin
      biSize         := sizeof(BITMAPINFOHEADER);
      biWidth        := ulWindowWidth - (ulWindowWidth div 5) * 2;
      ulBitmapWidth  := biWidth;
      biHeight       := ulWindowHeight - (ulWindowHeight div 5) * 2;
      ulBitmapHeight := biHeight;
      biPlanes       := 1;
      biBitCount     := 32;  // четыре восьмибитных состовляющих
      biCompression  := BI_RGB;
      biSizeImage    := ulBitmapWidth * ulBitmapHeight * 4;
    end;

  // создаем DIB секцию и выбираем точечный рисунок в контексте устройства
  hbmp := CreateDIBSection(hCurDC, bmi, DIB_RGB_COLORS, pvBits, 0, 0);
  SelectObject(hCurDC, hbmp);

  // в верхней области окна, постоянная альфа=50%, но исходная альфа отсутствует
  // цветовой формат для каждого пиксела 0xaarrggbb
  // установим пикселы в синий цвет и альфу в ноль
  for y := 0 to ulBitmapHeight - 1 do
    for x := 0 to ulBitmapWidth - 1 do
      PULONG(Integer(pvBits) +
             (x + y * ulBitmapWidth) * sizeof(ULONG))^ := $000000ff;

  bf.BlendOp     := AC_SRC_OVER;
  bf.BlendFlags  := 0;
  bf.AlphaFormat := 0;            // игнорировать исходный альфа-канал
  bf.SourceConstantAlpha := $7f;  // половина $ff = 50% прозрачности

  if not Windows.AlphaBlend(hdcwnd, ulWindowWidth div 5,
                    ulWindowHeight div 5,
                    ulBitmapWidth, ulBitmapHeight,
                    hCurDC, 0, 0, ulBitmapWidth, ulBitmapHeight, bf) then
    begin
      DeleteObject(hbmp);
      DeleteDC(hCurDC);
      Exit;
    end;

  // в средней области постоянная альфа=100%, а исходная равно 0
  for y := 0 to ulBitmapHeight - 1 do
    for x := 0 to ulBitmapWidth - 1 do
      if (x > Integer(ulBitmapWidth div 5)) and
         (x < (ulBitmapWidth - ulBitmapWidth div 5)) and
         (y > Integer(ulBitmapHeight div 5)) and
         (y < (ulBitmapHeight - ulBitmapHeight div 5)) then
        // в середине точечного рисунка альфа равна нулю
        // это означает, что каждый цветной компонент умножается на 0
        // Таким образом, после альфа-смешивания, мы получим 0 * r,
        // 0x00 * g, 0x00 * b ($00000000)
        // установим сейчас цвет пикселов в красный
        PULONG(Integer(pvBits) +
               (x + y * ulBitmapWidth) * sizeof(ULONG))^ := $0000ff00
      else
        // остальную часть точечного рисунка сделаем синей
        PULONG(Integer(pvBits) +
               (x + y * ulBitmapWidth) * sizeof(ULONG))^ := $00ff0000;

  bf.BlendOp     := AC_SRC_OVER;
  bf.BlendFlags  := 0;
  bf.AlphaFormat := AC_SRC_ALPHA;  // используем исходную альфа
  bf.SourceConstantAlpha := $ff;  // непрозрачный

  if not Windows.AlphaBlend(hdcwnd, ulWindowWidth div 5,
       ulWindowHeight div 5 + ulWindowHeight, ulBitmapWidth, ulBitmapHeight,
       hCurDC, 0, 0, ulBitmapWidth, ulBitmapHeight, bf) then
    begin
      DeleteObject(hbmp);
      DeleteDC(hCurDC);
      Exit;
    end;

  // нижняя область. используем альфа=75% и переменную исходную альфу.
  // создаем градиентный эффект использую исходную альфа
  ubRed   := $ff;
  ubGreen := $00;
  ubBlue  := $00;

  for y := 0 to ulBitmapHeight - 1 do
    for x := 0 to ulBitmapWidth - 1 do
      begin
        ubAlpha := Trunc(x / ulBitmapWidth * 255) and $FF;
        fAlphaFactor := ubAlpha / $ff;

        r := (Round(ubRed   * fAlphaFactor) * (1 shl 16)) and $FF;
        g := (Round(ubGreen * fAlphaFactor) * (1 shl 8)) and $FF;
        b :=  Round(ubBlue  * fAlphaFactor) and $FF;
        PULONG(Integer(pvBits) +
               (x + y * ulBitmapWidth) * sizeof(ULONG))^ :=
          (ubAlpha shl 24) or //0xaa000000
          r or  //0x00rr0000
          g or  //0x0000gg00
          b;    //0x000000bb
      end;

  bf.BlendOp     := AC_SRC_OVER;
  bf.BlendFlags  := 0;
  bf.AlphaFormat := AC_SRC_ALPHA;
  bf.SourceConstantAlpha := $bf;

  Windows.AlphaBlend(hdcwnd, ulWindowWidth div 5,
               ulWindowHeight div 5 + 2 * ulWindowHeight, ulBitmapWidth,
               ulBitmapHeight, hCurDC, 0, 0, ulBitmapWidth,
               ulBitmapHeight, bf);

  DeleteObject(hbmp);
  DeleteDC(hCurDC);
end;

procedure TfmAlphaBlending.FormPaint(Sender: TObject);
var
  hCurDC: HDC;
  hCurBrush: HBRUSH;
begin
  hCurDC := GetDC(Handle);
  hCurBrush := CreateSolidBrush(RGB(128, 128, 255));
  FillRect(hCurDC, Rect(0, 0, Width, Height), hCurBrush);
  DrawAlphaBlend(Handle, hCurDC);
  DeleteObject(hCurBrush);
  ReleaseDC(Handle, hCurDC);
end;

end.
