Текущий архив: 2004.05.02;
Скачать: CL | DM;

Вниз

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

← →
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. Дело вкуса.

---

← →
fatal ©   (2004-04-09 14:09) [14]

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

---

← →
Amoeba ©   (2004-04-12 16:19) [15]

Смотрим:
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;

---

← →
Мишка Кулясов ©   (2004-04-12 21:08) [18]

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

---

Страницы: 1 вся ветка

Текущий архив: 2004.05.02;
Скачать: CL | DM;

Наверх

Память: 0.51 MB
Время: 0.025 c