//随意改变我的窗体的透明度，还有颜色等
这个控件都可以实现：
unit Glassy;
interface
uses
Windows, Messages, Classes, Graphics, Controls, Forms, ExtCtrls;
type
THoundred = 0..100;
TGlassy = class(TPaintBox)
private
FMoveable: Boolean;
FTranspColor: TColor;
FTransparency: THoundred;
ScreenShoot: TBitmap;
ParentForm: TForm;
PrevParentWndProc: Pointer;
ShiftX, ShiftY: Integer;
CanTakeScreen: Boolean;
procedure NewParentWndProc(var Msg: TMessage);
procedure TakeScreenShoot;
procedure SetTranspColor(Value: TColor);
procedure SetTransparency(Value: THoundred);
protected
procedure SetParent(Value: TWinControl);
override;
public
constructor Create(aOwner: TComponent);
override;
destructor Destroy;
override;
procedure Loaded;
override;
procedure Paint;
override;
published
property Moveable: Boolean read FMoveable write FMoveable;
property TranspColor: TColor read FTranspColor write SetTranspColor;
property Transparency: THoundred read FTransparency write SetTransparency;
end;
procedure Register;
implementation
type
PRGBArray = ^TRGBArray;
TRGBArray = Array[0..1000000] of TRGBTriple;
constructor TGlassy.Create(aOwner: TComponent);
var
p: Pointer;
begin
inherited Create(aOwner);
FMoveable := True;
FTransparency := 60;
FTranspColor := clBlack;
ParentForm := TForm(aOwner);
ScreenShoot := TBitmap.Create;
{ Setting hook on parent form }
PrevParentWndProc := Pointer(GetWindowLong(ParentForm.Handle, GWL_WNDPROC));
p := MakeObjectInstance(NewParentWndProc);
SetWindowLong(ParentForm.Handle, GWL_WNDPROC, LongInt(p));
CanTakeScreen := True;
end;
destructor TGlassy.Destroy;
begin
if ParentForm.HandleAllocated then
SetWindowLong(ParentForm.Handle, GWL_WNDPROC, LongInt(PrevParentWndProc));
if ScreenShoot <> nil then
ScreenShoot.Destroy;
inherited Destroy;
end;
procedure TGlassy.Loaded;
begin
inherited Loaded;
TakeScreenShoot;
end;
procedure TGlassy.SetParent(Value: TWinControl);
begin
inherited SetParent(Value);
if Value <> nil then
begin
ShiftX := 0;
ShiftY := 0;
while not (Value is TForm)do
begin
inc(ShiftX, Value.Left);
inc(ShiftY, Value.Top);
Value := Value.Parent;
end;
end;
end;
procedure TGlassy.Paint;
var
X, Y: Integer;
begin
inherited Paint;
if (csDesigning in ComponentState) or (ScreenShoot = nil) then
Exit;
X := ParentForm.Left + Left + ShiftX;
Y := ParentForm.Top + Top + ShiftY;
with ParentFormdo
begin
if WindowState = wsNormal then
case BorderStyle of
bsSingle,
bsDialog: begin
inc(X, GetSystemMetrics(sm_CXDlgFrame));
inc(Y, GetSystemMetrics(sm_CYDlgFrame));
end;
bsSizeable: begin
inc(X, GetSystemMetrics(sm_CXFrame));
inc(Y, GetSystemMetrics(sm_CYFrame));
end;
bsToolWindow,
bsSizeToolWin: begin
inc(X, GetSystemMetrics(sm_CXBorder));
inc(Y, GetSystemMetrics(sm_CYBorder));
end;
end;
if BorderStyle <> bsNone then
inc(Y, GetSystemMetrics(sm_CYCaption));
end;
if ScreenShoot <> nil then
BitBlt(Canvas.Handle, 0, 0, ScreenShoot.Width, ScreenShoot.Height,
ScreenShoot.Canvas.Handle, X, Y, SrcCopy);
CanTakeScreen := True;
end;
procedure TGlassy.NewParentWndProc(var Msg: TMessage);
begin
Msg.Result := CallWindowProc(PrevParentWndProc, ParentForm.Handle, Msg.Msg,
Msg.WParam, Msg.LParam);
case Msg.Msg of
wm_Activate: if (Lo(Msg.wParam) <> wa_Inactive) and
CanTakeScreen then
TakeScreenShoot;
wm_Move: Paint;
wm_NCHitTest: if not (csDesigning in ComponentState) and
FMoveable and (Msg.Result = htClient) then
Msg.Result := htCaption
end;
end;
procedure TGlassy.TakeScreenShoot;
var
DC: hDC;
ScreenWidth, ScreenHeight: Integer;
SL: PRGBArray;
X, Y: Integer;
begin
if (csDesigning in ComponentState) or (ScreenShoot = nil) then
Exit;
CanTakeScreen := False;
ScreenWidth := GetSystemMetrics(sm_CXScreen);
ScreenHeight := GetSystemMetrics(sm_CYScreen);
ScreenShoot.Width := ScreenWidth;
ScreenShoot.Height := ScreenHeight;
ScreenShoot.PixelFormat := pf24bit;
ShowWindow(ParentForm.Handle, SW_Hide);
SetActiveWindow(0);
Sleep(100);
// Waiting when all windows will be redrawn...
DC := GetDC(0);
BitBlt(ScreenShoot.Canvas.Handle, 0, 0,
ScreenWidth, ScreenHeight, DC, 0, 0, SrcCopy);
ReleaseDC(0, DC);
for Y := 0 to ScreenHeight - 1do
begin
SL := ScreenShoot.ScanLine[Y];
for X := 0 to ScreenWidth - 1do
begin
try
SL[X].rgbtRed := (FTransparency * SL[X].rgbtRed + (100 - FTransparency) * GetRValue(FTranspColor)) div 100;
SL[X].rgbtGreen := (FTransparency * SL[X].rgbtGreen + (100 - FTransparency)* GetGValue(FTranspColor)) div 100;
SL[X].rgbtBlue := (FTransparency * SL[X].rgbtBlue + (100 - FTransparency) * GetBValue(FTranspColor)) div 100;
except
end;
end
end;
ShowWindow(ParentForm.Handle, sw_Show);
end;
procedure TGlassy.SetTranspColor(Value: TColor);
begin
if FTranspColor <> Value then
begin
FTranspColor := Value;
if ScreenShoot <> nil then
begin
TakeScreenShoot;
Paint;
end;
end;
end;
procedure TGlassy.SetTransparency(Value: THoundred);
begin
if FTransparency <> Value then
begin
FTransparency := Value;
if ScreenShoot <> nil then
begin
TakeScreenShoot;
Paint;
end;
end;
end;
procedure Register;
begin
RegisterComponents('Xacker', [TGlassy]);
end;
end.
