Полупрозрачные окна

← →
fatal © (2004-04-09 12:28) [0]

Подскажите пожалуйста как в Delphi реализовать полупрозрачный стиль окна. У кого нибудь получалось?

Спасибо.

← →
tpa (2004-04-09 12:38) [1]

Кажется в RX есть компонент TTransparentForm. Кладешь на форму рискунок с transparent краями - получаешь не прямоугольную форму. Делаешь в русунке transparent дырочки - получаешь полупрозрачную форму.

← →
fatal © (2004-04-09 12:44) [2]

Где раздобыть этот RX?

← →
tpa (2004-04-09 12:50) [3]

Стыдно батенька :) ищи RxLib в инете.

← →
serge © (2004-04-09 12:52) [4]

In the big garbage heap named Internet :o))))

← →
fatal © (2004-04-09 12:53) [5]

Спасибо найду.
Но вопрос остается открытым, еще есть у кого предложения?

← →
serge © (2004-04-09 12:54) [6]

Есть - поискать по разным преразным факам разбросанных по Инетрнету :)

← →
alless © (2004-04-09 12:59) [7]

procedure TForm1.FormCreate(Sender: TObject);
begin
form1.AlphaBlend:=true;
form1.AlphaBlendValue:=100;
end;

← →
fatal © (2004-04-09 13:01) [8]

У меня этих факов на локали до ...., результат=0.

← →
tpa (2004-04-09 13:11) [9]

Извини fatal :( Нет этого компонента в RxLib. Вот он:

unit TrForm;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs;

type
TtrRegion = class;

TTransparentForm = class(TComponent)
private
FMask: TBitmap;
FOwner: TCustomForm;
FRgn: TtpRegion;
FRegion: HRGN;
FAutoSize: Boolean;
FEnable: Boolean;
procedure SetEnable(Value: Boolean);
procedure SetMask(Value: TBitmap);
procedure SetAutoSize(Value: Boolean);
protected
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Mask: TBitmap read FMask write SetMask;
property Enable: Boolean read FEnable write SetEnable;
property AutoSize: Boolean read FAutoSize write SetAutoSize;
end;

TtrRegion = class(TComponent)
published
function RegionFromBitmap(Image: TBitmap): HRGN;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents("Add", [TTransparentForm]);
end;

constructor TTransparentForm.Create(AOwner: TComponent);
begin
inherited;
FOwner := GetParentForm(TControl(AOwner));
FMask := TBitmap.Create;
FRgn := TtpRegion.Create(Self);
end;

destructor TTransparentForm.Destroy;
begin
if not (csDestroying in FOwner.ComponentState) then
begin
SetWindowLong(FOwner.Handle, GWL_STYLE,
GetWindowLong(FOwner.Handle, GWL_STYLE) or WS_CAPTION);
SetWindowRgn(FOwner.Handle, 0, True);
end;
FRgn.Free;
FMask.Free;
inherited;
end;

procedure TTransparentForm.SetMask(Value: TBitmap);
begin
FMask.Assign(Value);
FRegion := FRgn.RegionFromBitmap(Value);
if FEnable then
SetWindowRgn(FOwner.Handle, FRegion, True)
else
SetWindowRgn(FOwner.Handle, 0, True);
if FEnable and FAutoSize then
begin
FOwner.Width := FMask.Width;
FOwner.Height := FMask.Height;
end;
end;

procedure TTransparentForm.SetEnable(Value: Boolean);
begin
FEnable := Value;
if Value then
begin
SetWindowLong(FOwner.Handle, GWL_style,
GetWindowLong(FOwner.Handle, GWL_style) and not WS_CAPTION);
FRegion := FRgn.RegionFromBitmap(FMask);
SetWindowRgn(FOwner.Handle, FRegion, True);
if FAutoSize then
begin
FOwner.Width := FMask.Width;
FOwner.Height := FMask.Height;
end;
end
else
begin
SetWindowLong(FOwner.Handle, GWL_STYLE,
GetWindowLong(FOwner.Handle, GWL_STYLE) or WS_CAPTION);
SetWindowRgn(FOwner.Handle, 0, True);
end;
end;

procedure TTransparentForm.SetAutoSize(Value: Boolean);
begin
FAutoSize := Value;
if Value and FEnable then
begin
FOwner.Width := FMask.Width;
FOwner.Height := FMask.Height;
end;
end;

const
MaxPixelCount = 32768;

type
PRGBArray = ^TRGBArray;
TRGBArray = array [0..MaxPixelCount - 1] of TRGBTriple;

function TtrRegion.RegionFromBitmap(Image: TBitmap): HRGN;
var
rgn1, rgn2: HRGN;
startx, endx, x, y: Integer;
TransparentColor: TRGBTriple;
bmp: TBitmap;
p: PRGBArray;
begin
rgn1 := 0;

bmp := TBitmap.Create;
bmp.Assign(Image);
bmp.PixelFormat := pf24Bit;

if (bmp.Height > 0) and (bmp.Width > 0) then
begin
p := bmp.ScanLine[0];
TransparentColor := p[0];
end;

for y := 0 to bmp.Height - 1 do
begin
x := 0;
p := bmp.ScanLine[y];
repeat
while (x < bmp.Width) and (CompareMem(@p[x], @TransparentColor, 3)) do
Inc(x);
Inc(x);
startx := x;
while (x < bmp.Width) and (not (CompareMem(@p[x], @TransparentColor, 3))) do
Inc(x);
endx := x;

if startx < bmp.Width then
begin
if rgn1 = 0 then
rgn1 := CreateRectRgn(startx + 1, y, endx, y + 1)
else
begin
rgn2 := CreateRectRgn(startx + 1, y, endx, y + 1);
if rgn2 <> 0 then
CombineRgn(rgn1, rgn1, rgn2, RGN_OR);
DeleteObject(rgn2);
end;
end;
until x >= Image.Width;
end;

bmp.Free;
Result := rgn1;
end;

end.

← →
alless © (2004-04-09 13:12) [10]

a tot kod kotorii ia tebe dal ne rabotaiet? On ne budet rabotati tolico v win98,95

← →
sir John © (2004-04-09 13:19) [11]

предложения есть. Можно вот так сделать:
private FullRgn, ClientRgn, CtlRgn: THandle; procedure MakeTransparent; procedure UndoTransparent;

procedure TForm1.MakeTransparent; var AControl: TControl; A, Margin, X, Y, CtlX, CtlY: Integer; begin Margin := (Width - ClientWidth) div 2; FullRgn := CreateRectRgn(0, 0, Width, Height); X := Margin; Y := Height - ClientHeight - Margin; ClientRgn := CreateRectRgn(X, Y, X + ClientWidth, Y + ClientHeight); CombineRgn(FullRgn, FullRgn, ClientRgn, RGN_DIFF); for A := 0 to ControlCount - 1 do begin AControl := Controls[A]; if (AControl is TWinControl) or (AControl is TGraphicControl) then with AControl do begin if Visible then begin CtlX := X + Left; CtlY := Y + Top; CtlRgn := CreateRectRgn(CtlX, CtlY, CtlX + Width, CtlY + Height); CombineRgn(FullRgn, FullRgn, CtlRgn, RGN_OR); end; end; end; SetWindowRgn(Handle, FullRgn, True); end; procedure TForm1.UndoTransparent; begin FullRgn := CreateRectRgn(0, 0, Width, Height); CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY); SetWindowRgn(Handle, FullRgn, True); end;

тест. Две кнопки на форме

procedure TForm1.SpeedButton1Click(Sender: TObject); begin MakeTransparent; end; procedure TForm1.SpeedButton2Click(Sender: TObject); begin UndoTransparent; end;

вот собственно и все...

← →
Ann © (2004-04-09 13:20) [12]

А зачем компонент, если то что привел alless прекрасно работает?

← →
tpa (2004-04-09 13:32) [13]

Речь кажется идет о форме , а у alles полупрозрачными становятся все контролы. В варианте sir John идея таже самая, что и в TTransparentForm. Дело вкуса.

to alless
Ооо большое спасибо.
Получилось просто супер.

Смотрим:
http://www.delphikingdom.com/asp/viewitem.asp?catalogid=30

← →
Боян Георгиев (2004-04-12 21:04) [16]

Прозрачная форма:
Form1.AlphaBlend := true; Form1.AlphaBlendValue := 50;

Полупрозрачная форма:
Form1.AlphaBlend := true; Form1.AlphaBlendValue := 100;

Работает только для XP.

← →
Боян Георгиев (2004-04-12 21:06) [17]

Ошибался.

Прозрачная форма:
Form1.AlphaBlend := true;
Form1.AlphaBlendValue := 100;

Полупрозрачная форма:
Form1.AlphaBlend := true;
Form1.AlphaBlendValue := 50;

Вместе с FormRgn поставляется пример с настоящей полупрозрачностью в любых версиях Windows.

Полупрозрачные окна Найти похожие ветки