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

Вниз

Работа с формами   Найти похожие ветки 

 
staratel   (2002-08-16 13:30) [0]

Народ, подскажите кто-нибудь можно ли сделать прозрачность формы в Win9x? Имеющаяся опция AlphaBlend в Delphi6 работает только с Win2000/NT/XP, а как это можно сделать в Win98?


 
stany   (2002-08-19 00:16) [1]

Есть два варианта.1)Рисуетюся только те части формы под которыми
есть компоненты:
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Panel1: TPanel;
Button2: TButton;
procedure FormDestroy(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure FormResize(Sender: TObject);
private
{ Private declarations }
procedure DoVisible;
procedure DoInvisible;
public
{ Public declarations }
end;

var
Form1: TForm1;
FullRgn, ClientRgn, CtlRgn : THandle;

implementation

{$R *.DFM}

procedure TForm1.DoInvisible;
var
AControl : TControl;
A, Margin, X, Y, CtlX, CtlY : Integer;
begin
Margin := ( Width - ClientWidth ) div 2;
//First, get form region
FullRgn := CreateRectRgn(0, 0, Width, Height);
//Find client area region
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;
//When the region is all ready, put it into effect:
SetWindowRgn(Handle, FullRgn, TRUE);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
//Clean up the regions we created
DeleteObject(ClientRgn);
DeleteObject(FullRgn);
DeleteObject(CtlRgn);
end;

procedure TForm1.DoVisible;
begin
FullRgn := CreateRectRgn(0, 0, Width, Height);
CombineRgn(FullRgn, FullRgn, FullRgn, RGN_COPY);
SetWindowRgn(Handle, FullRgn, TRUE);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
//We start out as a transparent form....
DoInvisible;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if Button1.Caption = "Show Form" then begin
DoVisible;
Button1.Caption := "Hide Form";
end
else begin
DoInvisible;
Button1.Caption := "Show Form";
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Application.Terminate;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
if Button1.Caption = "Show Form" then
DoInvisible
else
DoVisible;
end;

end.



 
stany   (2002-08-19 00:28) [2]

2)Настоящая прозрачность, но медленно и ненадёжно работает

unit Unit1;


interface

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

type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
ColorDialog1: TColorDialog;
SpinEdit1: TSpinEdit;
Label2: TLabel;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure SpinEdit1Change(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
BM:TBitmap;
BM2:TBitmap;
Moving:Boolean;
procedure WMEraseBkgnd(var Msg:TWMEraseBkgnd);message WM_EraseBkgnd;
procedure WMPaint(var Msg:TWMPaint);message WM_Paint;
procedure WMMove(var Msg:TMessage);message WM_Move;
procedure WMEnterSizeMove(var Msg:TMessage);message WM_EnterSizeMove;
procedure WMExitSizeMove(var Msg:TMessage);message WM_ExitSizeMove;
public
{ Public declarations }
end;

var
Form1: TForm1;

const Transparency:Integer=40; { Прозрачность в процентах. Должна быть от 0 до 100 }
TranspColor:TColor=clBlack; { Цвет окна }
DelayTime:Integer=400; { Время задержки в миллисекундах }

implementation

{$R *.DFM}

type PRGBArray=^TRGBArray;
TRGBArray=array[0..1000000] of TRGBTriple;

procedure Delay(DelayTime:Integer);
var TicksNow:Integer;
begin
TicksNow:=GetTickCount;
repeat
Application.ProcessMessages
until GetTickCount-TicksNow>=DelayTime
end;

procedure TForm1.WMEraseBkgnd;
begin
Msg.Result:=1
end;

procedure TForm1.WMPaint;
var DC:HDC;
PS:TPaintStruct;
CW,CH,CX,CY:Integer;
SL:PRGBArray;
X,Y:Integer;
begin
CW:=ClientWidth;
CH:=ClientHeight;
CX:=ClientOrigin.X;.
CY:=ClientOrigin.Y;

if not Moving then
begin
ShowWindow(Handle,SW_Hide);
SetActiveWindow(0);
Delay(400);
DC:=GetDC(0);

BitBlt(BM.Canvas.Handle,0,0,BM.Width,BM.Height,DC,0,0,SrcCopy);

ReleaseDC(0,DC);
end;

BM2.Width:=CW+1;
BM2.Height:=CH+1;
BM2.PixelFormat:=pf24bit;
BM2.Canvas.Draw(-CX,-CY,BM);
for Y:=0 to CH do // А в этих циклах на записанный нами кусок экрана
begin // Накладывается светофильтр
SL:=BM2.ScanLine[Y];
for X:=0 to CW do
begin
SL[X].rgbtRed:=(Transparency*SL[X].rgbtRed+(100-Transparency)*GetRValue(TranspColor)) div 100;
SL[X].rgbtGreen:=(Transparency*SL[X].rgbtGreen+(100-Transparency)*GetGValue(TranspColor)) div 100;
SL[X].rgbtBlue:=(Transparency*SL[X].rgbtBlue+(100-Transparency)*GetBValue(TranspColor)) div 100
end
end;

ShowWindow(Handle,SW_Show);
DC:=BeginPaint(Handle,PS);
BitBlt(DC,0,0,BM2.Width,BM2.Height,BM2.Canvas.Handle,0,0,SrcCopy);

Msg.DC:=DC;
inherited;
EndPaint(Handle,PS) // Ну, в общем-то и всё...
end;

procedure TForm1.WMMove;
begin
Invalidate;
inherited
end;

procedure TForm1.WMEnterSizeMove;
begin
Moving:=True;
inherited
end;

procedure TForm1.WMExitSizeMove;
begin
inherited;
Moving:=False
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
BM:=TBitmap.Create;
BM.Width:=GetSystemMetrics(SM_CXScreen);
BM.Height:=GetSystemMetrics(SM_CYScreen);

BM.PixelFormat:=pf24bit;
BM2:=TBitmap.Create;
Moving:=False
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
begin
TranspColor:=ColorDialog1.Color;
Invalidate
end
end;

procedure TForm1.SpinEdit1Change(Sender: TObject);
begin
Transparency:=SpinEdit1.Value;
Invalidate
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
BM.Free;
BM2.Free
end;

end.

================================Удачи!=========================



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

Форум: "Основная";
Текущий архив: 2002.08.29;
Скачать: [xml.tar.bz2];

Наверх





Память: 0.47 MB
Время: 0.011 c
1-95769
Kettle of delphi
2002-08-18 19:41
2002.08.29
Windows виснет. Не могу найти ошибку. Код простой. Помогите :)


3-95723
rex
2002-08-09 12:30
2002.08.29
В FastReport е не отображаются данные (типа Дата) из таблицы.


1-95797
^Sanya
2002-08-20 00:11
2002.08.29
WinXP Processes


1-95880
ioRaptor
2002-08-18 14:11
2002.08.29
Как с помощю UpDown прокручивать вещественные числа


1-95752
Mr
2002-08-19 10:52
2002.08.29
Создание объектов во время работы программы !!!





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
Английский Французский Немецкий Итальянский Португальский Русский Испанский