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.
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.