Form transparante avec couleur de choix et niveau de transparance

Soyez le premier à donner votre avis sur cette source.

Vue 7 420 fois - Téléchargée 1 105 fois

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.

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

Messages postés
14
Date d'inscription
samedi 31 juillet 2004
Statut
Membre
Dernière intervention
11 août 2004

CA me rend malade...

N' y a t' il pas moyen de faire disparaitre la barre titre???
Messages postés
103
Date d'inscription
dimanche 19 janvier 2003
Statut
Membre
Dernière intervention
19 septembre 2010

essaiez de faire dans la proprité aligne de imgRect (l'image) alClient
pour que l'image prond tout la form.
Messages postés
871
Date d'inscription
dimanche 6 janvier 2002
Statut
Membre
Dernière intervention
3 novembre 2005
1
J'ai l'impression que ça ne marche pas à tous les coups... Une fois, je me retrouve avec une form à moitié transparente, une autre fois bien comme il faut, et encore une autre fois complètement opaque !!

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.