Form transparante avec couleur de choix et niveau de transparance

Télécharger le projet
Commenter

Description

ce code n'est pas le mien
ce code ma beaucoup plu; je bien que les conaisseur puisse l'amiliorer
en minimizant le temp de reaffichage.
et de faire rester la transparance au depalacement de la form

Source / Exemple : 


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 projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_skiso)