|
Trouver une ressource
Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum. Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !
FORM TRANSPARANTE AVEC COULEUR DE CHOIX ET NIVEAU DE TRANSPARANCE
Information sur la source
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
- 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.
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.
Fichier Zip
Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !
Télécharger le zip
Sources du même auteur
Sources de la même categorie
Commentaires et avis
|
Comparez les prix Nouvelle version
|