Рисуем не стандартное окно в дельфи...

← →
3223(jab) (2003-06-24 09:38) [0]

Иногда хочется нарисовать окно в виде картинки с различными просвечивающими участками. Всем кто это искал и не нашел забирайте! Те кто знает как можно уличшить опишите плиз!

/////////////////////////////////
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Image1: TImage;
procedure FormCreate(Sender: TObject);
function BitmapToRgn(Image: TBitmap): HRGN;
private
{ Private declarations }
public
{ Public declarations }
procedure WMNCHITTEST(var Mes:Tmessage); Message WM_NCHITTEST;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCHITTEST(var Mes:Tmessage);
begin
Mes.Result := HTCAPTION;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
MyRGN : HRGN;
b: TBitmap;
begin
//MyRGN := CreateRoundRectRgn(0, 0, Width, Height, 30, 30);
Image1.Picture.LoadFromFile(ExtractFilePath(ParamStr(1))+"rex2.bmp");
b:=TBitmap.Create;
b.LoadFromFile(ExtractFilePath(ParamStr(1))+"rex.bmp");
form1.Width:=b.Width; form1.Height:=b.Height;
MyRGN := BitmapToRgn(b);
b.free;
SetWindowRgn(Handle, MyRGN, True);
DeleteObject(MyRGN);
end;

function TForm1.BitmapToRgn(Image: TBitmap): HRGN;
var
TmpRgn: HRGN;
x, y: integer;
ConsecutivePixels: integer;
CurrentPixel: TColor;
CreatedRgns: integer;
CurrentColor: TColor;
begin
CreatedRgns := 0;
Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
inc(CreatedRgns);

if (Image.Width = 0) or (Image.Height = 0) then exit;

for y := 0 to Image.Height - 1 do
begin
CurrentColor := Image.Canvas.Pixels[0,y];
ConsecutivePixels := 1;
for x := 0 to Image.Width - 1 do
begin
CurrentPixel := Image.Canvas.Pixels[x,y];

if CurrentColor = CurrentPixel
then inc(ConsecutivePixels)
else begin
// Входим в новую зону
if CurrentColor = clWhite then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
CurrentColor := CurrentPixel;
ConsecutivePixels := 1;
end;
end;

if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
( TmpRgn) Иногда хочется нарисовать окно в виде картинки с различными просвечивающими участками. Всем кто это искал и не нашел забирайте! Те кто знает как можно уличшить опишите плиз!

/////////////////////////////////
unit Unit1;

interface

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

type
TForm1 = class(TForm)
Image1: TImage;
procedure FormCreate(Sender: TObject);
function BitmapToRgn(Image: TBitmap): HRGN;
private
{ Private declarations }
public
{ Public declarations }
procedure WMNCHITTEST(var Mes:Tmessage); Message WM_NCHITTEST;
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMNCHITTEST(var Mes:Tmessage);
begin
Mes.Result := HTCAPTION;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
MyRGN : HRGN;
b: TBitmap;
begin
//MyRGN := CreateRoundRectRgn(0, 0, Width, Height, 30, 30);
Image1.Picture.LoadFromFile(ExtractFilePath(ParamStr(1))+"rex2.bmp");
b:=TBitmap.Create;
b.LoadFromFile(ExtractFilePath(ParamStr(1))+"rex.bmp");
form1.Width:=b.Width; form1.Height:=b.Height;
MyRGN := BitmapToRgn(b);
b.free;
SetWindowRgn(Handle, MyRGN, True);
DeleteObject(MyRGN);
end;

function TForm1.BitmapToRgn(Image: TBitmap): HRGN;
var
TmpRgn: HRGN;
x, y: integer;
ConsecutivePixels: integer;
CurrentPixel: TColor;
CreatedRgns: integer;
CurrentColor: TColor;
begin
CreatedRgns := 0;
Result := CreateRectRgn(0, 0, Image.Width, Image.Height);
inc(CreatedRgns);

if (Image.Width = 0) or (Image.Height = 0) then exit;

for y := 0 to Image.Height - 1 do
begin
CurrentColor := Image.Canvas.Pixels[0,y];
ConsecutivePixels := 1;
for x := 0 to Image.Width - 1 do
begin
CurrentPixel := Image.Canvas.Pixels[x,y];

if CurrentColor = CurrentPixel
then inc(ConsecutivePixels)
else begin
// Входим в новую зону
if CurrentColor = clWhite then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
CurrentColor := CurrentPixel;
ConsecutivePixels := 1;
end;
end;

if (CurrentColor = clWhite) and (ConsecutivePixels > 0) then
begin
TmpRgn := CreateRectRgn(x-ConsecutivePixels, y, x, y+1);
CombineRgn(Result, Result, TmpRgn, RGN_DIFF);
inc(CreatedRgns);
DeleteObject(TmpRgn);
end;
end;
end;

end.
/////////////////////////////////

Где: rex.bmp это маска, а rex2.bmp это сама картинка.
Маска просвечивает все белые места, а для чёрных или любого другого цвета создаёт поверхность.

← →
3223(jab) (2003-06-24 09:40) [1]

Ой... ещё раз добавил случайно!!! Лажа вышла. :)

Рисуем не стандартное окно в дельфи... Найти похожие ветки