Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 2004.05.02;
Скачать: [xml.tar.bz2];

Вниз

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

 
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;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.5 MB
Время: 0.034 c
8-1075968210
SH
2004-02-05 11:03
2004.05.02
Чёрнобелый Jpeg


7-1078907116
Alex*
2004-03-10 11:25
2004.05.02
Двусторонняя печать


6-1078419776
Vilux
2004-03-04 20:02
2004.05.02
SMPP


8-1075498267
Graff
2004-01-31 00:31
2004.05.02
На чем рисовать?


3-1081240823
GIL
2004-04-06 12:40
2004.05.02
Работа с Yaffil





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский