unit Unit1;

interface

uses
 Windows, Messages, Classes, Graphics, Forms;

type
 TRGB = record
   B, G, R: Byte;
 end;
 pRGB = ^TRGB;

 TForm1 = class(TForm)
   procedure FormPaint(Sender: TObject);
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
 private
   fBmp: TBitmap;

   PrevParentWndProc: Pointer;
   procedure NewParentWndProc(var Msg: TMessage);
 end;

var
 Form1: TForm1;
 FTransparency: Integer;
 FTranspColor: TColor;

implementation

{$R *.dfm}

{Ñìåøèâàíèå öâåòîâ}
function MixBytes(FG, BG, TRANS: byte): byte;
 asm
   push bx
   push cx
   push dx
   mov DH,TRANS
   mov BL,FG
   mov AL,DH
   mov CL,BG
   xor AH,AH
   xor BH,BH
   xor CH,CH
   mul BL
   mov BX,AX
   xor AH,AH
   mov AL,DH
   xor AL,$FF
   mul CL
   add AX,BX
   shr AX,8
   pop dx
   pop cx
   pop bx      
end;

{Âûçîâ ïðîöåäóðû ñìåøèâàíèÿ öâåòîâ äëÿ êàæäîãî pixel}
procedure MixColors(Bitmap: TBitmap; Color: TColor);
var
 x, y: Integer;
 Dest: pRGB;
 fR, fG, fB: Byte;
begin
 fR:=GetRValue(FTranspColor);
 fG:=GetGValue(FTranspColor);
 fB:=GetBValue(FTranspColor);

 for y := 0 to Bitmap.Height - 1 do
 begin
   Dest := Bitmap.ScanLine[y];
   for x := 0 to Bitmap.Width - 1 do
   begin
     with Dest^ do
     begin
       R:=MixBytes(fR, R, FTransparency);
       G:=MixBytes(fG, G, FTransparency);
       B:=MixBytes(fB, B, FTransparency);
     end;
     Inc(Dest);
   end;
 end;
end;

{çàõâàò DC è îòðèñîâêà íà Canvas}
procedure TForm1.FormPaint(Sender: TObject);
var
 DC: hDC;
 P, A: Tpoint;
begin
 P:=Point(0, 0);
 A:=ClientToScreen(P);

 DC:=GetDC(0);
 BitBlt(fBmp.Canvas.Handle, 0, 0, ClientWidth, ClientHeight, DC, A.X, A.Y, SrcCopy);
 ReleaseDC(0, DC);

 MixColors(fBmp, FTranspColor);
 BitBlt(Canvas.Handle, P.X, P.Y, fBmp.Width, fBmp.Height, fBmp.canvas.Handle, 0, 0, SRCCOPY);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
 p: Pointer;
begin
 TransparentColorValue:=$00000001;
 TransparentColor:=True;

 FTransparency:=150;
 FTranspColor:=clBlue;

 fBmp:=TBitmap.Create;
 fBmp.Width:=ClientWidth;
 fBmp.Height:=ClientHeight;
 fBmp.PixelFormat := pf24Bit;

 PrevParentWndProc:=Pointer(GetWindowLong(Handle, GWL_WNDPROC));
 p:=MakeObjectInstance(NewParentWndProc);
 SetWindowLong(Handle, GWL_WNDPROC, LongInt(p));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 fBmp.Free;
 if HandleAllocated then SetWindowLong(Handle, GWL_WNDPROC, LongInt(PrevParentWndProc));
end;

procedure TForm1.NewParentWndProc(var Msg: TMessage);
begin
 Msg.Result:=CallWindowProc(PrevParentWndProc, Handle, Msg.Msg, Msg.WParam, Msg.LParam);

 case Msg.Msg of
   wm_Move, WM_ACTIVATE: Paint;
  end;
end;

end.

TransparentColor:=False;

procedure TControl.SetAlphaBlend(const Value: Integer);
const
 LWA_COLORKEY=$00000001;
 LWA_ALPHA=$00000002;
 ULW_COLORKEY=$00000001;
 ULW_ALPHA=$00000002;
 ULW_OPAQUE=$00000004;
 WS_EX_LAYERED=$00080000;
type
 TSetLayeredWindowAttributes=
   function( hwnd: Integer; crKey: TColor; bAlpha: Byte; dwFlags: DWORD )
   : Boolean; stdcall;
var
 SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
 User32: THandle;
 dw: DWORD;
begin
 if Value = fAlphaBlend then Exit;
 fAlphaBlend := Value;
 User32 := GetModuleHandle( 'User32' );
 SetLayeredWindowAttributes := GetProcAddress( User32,
                            'SetLayeredWindowAttributes' );
 if Assigned( SetLayeredWindowAttributes ) then
 begin
   dw := GetWindowLong( GetWindowHandle, GWL_EXSTYLE );
   if Byte( Value ) < 255 then
   begin
     SetWindowLong( fHandle, GWL_EXSTYLE, dw or WS_EX_LAYERED );
     SetLayeredWindowAttributes( fHandle, 0, Value and $FF, LWA_ALPHA);
   end
      else
     SetWindowLong( fHandle, GWL_EXSTYLE, dw and not WS_EX_LAYERED );
 end;
end;

 private
   procedure WMPOCHANGE(var Msg: TMessage); message WM_WINDOWPOSCHANGED;
   procedure wmhittest(var Msg: TMessage); message WM_NCHITTEST;

procedure TForm1.WMPOCHANGE(var Msg: TMessage);
begin
 inherited;
 if Form2=nil then exit;

 Form2.Left:=Left+20;
 Form2.Top:=Top+20;
 form2.BringToFront;

end;

procedure TForm1.wmhittest(var Msg: TMessage);
var
 P: TPoint;
begin
 inherited;

 p := Point(msg.LParamLo, msg.LParamHi);
 p := ScreenToClient(p);
 if PtInRect(Rect(0, 0, Width, 20), P) then Msg.Result:=HTCAPTION;
end;