FORM TRANSPARANTE AVEC COULEUR DE CHOIX ET NIVEAU DE TRANSPARANCE

unit pasTranslucent;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls, ExtCtrls;

type
  TfrmTranslucent = class(TForm)
    imgRect: TImage;
    btnExit: TButton;
    pnlControls: TPanel;
    lblR: TLabel;
    scrR: TScrollBar;
    lblG: TLabel;
    scrG: TScrollBar;
    lblB: TLabel;
    scrB: TScrollBar;
    lblTransparency: TLabel;
    scrTransparency: TScrollBar;

    procedure FormCreate(Sender: TObject);
    procedure WMENTERSIZEMOVE(var Message: TMessage); message WM_ENTERSIZEMOVE;
    procedure WMEXITSIZEMOVE(var Message: TMessage); message WM_EXITSIZEMOVE;
    procedure DrawBackground;
    procedure DrawTranslucent(Color: TColor; Transparency: Byte);
    procedure FormDestroy(Sender: TObject);
    procedure btnExitClick(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure scrTransparencyScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
    procedure scrRScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
    procedure scrGScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
    procedure scrBScroll(Sender: TObject; ScrollCode: TScrollCode; var ScrollPos: Integer);
    procedure imgRectMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

   type TRGBTripleArray = array[word] OF TRGBTriple;
   type pRGBTriple = ^TRGBTriple;
   type pRGBTripleArray = ^TRGBTripleArray;
var
   TRGBTriple :
      PACKED RECORD
         rgbtBlue : BYTE;
         rgbtGreen: BYTE;
         rgbtRed  : BYTE;
      END;
   frmTranslucent: TfrmTranslucent;
   rRect: TRect;
   Bitmap: TBitmap;
   globalTransparency: Byte;
   globalR, globalG, globalB: Byte;
//*********************************************************************************************************
implementation

{$R *.dfm}
//*********************************************************************************************************
procedure TfrmTranslucent.DrawBackground;
{This procedure copies to our Bitmap the desktop area under the form}
var DCDesk: HDC; // Device Context handle of Desktop
begin
  {procedure DrawTranslucent won't work if the host computer isn't using a
   color depth of at least 24 bits (or is it 16? anyway, it might not work with palettes)}
  Bitmap.PixelFormat := pf24bit;
  Bitmap.Width  := imgRect.Width;
  Bitmap.Height := imgRect.Height;

  {Hide the form and then sleep to make sure all gui form elements are hidden from our desktop snapshot}
  Hide;
  //Sleep(120);{sleep value could be set accoring to either window size/resize or cpu speed}

  {Get the desktop Device Context handle}
  DCDesk := GetWindowDC(GetDesktopWindow);

  {BitBlit to our bitmap canvas}
  BitBlt(Bitmap.Canvas.Handle, imgRect.top - 4, imgRect.left - 20, imgRect.Width + 23, imgRect.Height + 23,
         DCDesk, left, top, SRCCOPY);//}

  {Release desktop handle}
  ReleaseDC(GetDesktopWindow, DCDesk);

  {call procedure to redraw our Bitmap with the specified color, thus creating the illusion of translucency}
  DrawTranslucent(rgb(globalR, globalG, globalB), globalTransparency);

  imgRect.Picture.Graphic := Bitmap;

  Show;

end;
//*********************************************************************************************************
procedure TfrmTranslucent.FormCreate(Sender: TObject);
begin

//  Width := 450; Height := 422;
top:=100; left:=150;

  globalR := 255;
  globalG := 255;
  globalB := 0;
  globalTransparency := 90;

  Bitmap := TBitmap.Create;

  DrawBackground;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.FormResize(Sender: TObject);
begin
   btnExit.Top := Height - 45;
   btnExit.Left := Width - 61;

   imgRect.Width := Width - 8;
   imgRect.Height := Height - 24;

   pnlControls.top := Height - 172;

   {Reset the bounds of the TRect used by our bitmap}
   rRect:= Rect(0,0,imgRect.width,imgRect.height);
end;
//*********************************************************************************************************
procedure TfrmTranslucent.FormDestroy(Sender: TObject);
begin
   {Release the bitmap from memory}
   Bitmap.Free;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.WMENTERSIZEMOVE(var Message: TMessage);
  {Detect when the form has started moving}
begin
  {If the user has the Drag Window Contents (Display Properties/Effects) option enabled, it will
   destroy the illusion of this program. So hide the image and redraw after the form has stopped moving.}
  Color := rgb(globalR div 2,globalG div 2,globalB div 2);
  imgRect.visible := false;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.WMEXITSIZEMOVE(var Message: TMessage);
  {Detect when the form has stopped moving}
begin
  DrawBackground;
  imgRect.visible := true;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.DrawTranslucent(Color: TColor; Transparency: Byte);
var
  i,j  :  Integer;
  Row:  pRGBTripleArray;
  pixelColor: TColor;
begin
   for j := 0 to Bitmap.Height-1 do
   begin
    {Access each pixel using Scanline}
    Row := Bitmap.Scanline[j];
    for i := 0 to Bitmap.Width-1 do
    begin
      with Row[i] do
      begin
         {Find the color of the current pixel and parse into RGB values}
         pixelColor := rgb(rgbtRed,rgbtGreen,rgbtBlue);

         {Color the pixel using both the Transparency and global color values.
          This algorithm was written by Steve Schafer and downloaded from The Delphi Pool.}
         rgbtRed   := Round(0.01 * (Transparency * GetRValue(pixelColor) + (100 - Transparency) * globalR));
         rgbtGreen := Round(0.01 * (Transparency * GetGValue(pixelColor) + (100 - Transparency) * globalG));
         rgbtBlue  := Round(0.01 * (Transparency * GetBValue(pixelColor) + (100 - Transparency) * globalB));
      end
    end
   end;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.btnExitClick(Sender: TObject);
begin
   Close;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.scrRScroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
   lblR.caption := 'R value  ' + IntToStr(ScrollPos);
   globalR := ScrollPos;

   {Redraw the image once the scroll is completed - if this becomes annoying then
   comment it out, tie it to a checkbox/boolean value, etc.}
   if ScrollCode = scEndScroll then DrawBackground;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.scrGScroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
   lblG.caption := 'G value  ' + IntToStr(ScrollPos);
   globalG := ScrollPos;

   {Redraw the image at the end of the scroll - if this becomes annoying then
   just comment it out, tie it to a checkbox/boolean value, etc.}
   if ScrollCode = scEndScroll then DrawBackground;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.scrBScroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
   lblB.caption := 'B value  ' + IntToStr(ScrollPos);
   globalB := ScrollPos;

   {Redraw the image once the scroll is completed - if this becomes annoying then
   comment it out, tie it to a checkbox/boolean value, etc.}
   if ScrollCode = scEndScroll then DrawBackground;
end;
//*********************************************************************************************************
procedure TfrmTranslucent.scrTransparencyScroll(Sender: TObject;
  ScrollCode: TScrollCode; var ScrollPos: Integer);
begin
   lblTransparency.caption := 'Transparency  ' + IntToStr(ScrollPos) + '%';
   globalTransparency := ScrollPos;

   {Redraw the image at the end of the scroll - if this becomes annoying then
   simply comment it out, tie it to a checkbox or boolean value, etc.}
   if ScrollCode = scEndScroll then DrawBackground;
end;
//*********************************************************************************************************


procedure TfrmTranslucent.imgRectMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
ReleaseCapture;
frmTranslucent.Perform(WM_SYSCOMMAND, $F012, 0);
end;

end.

Télécharger le zip