Форум: "WinAPI";
Текущий архив: 2003.08.25;
Скачать: [xml.tar.bz2];
ВнизРисуем не стандартное окно в дельфи... Найти похожие ветки
← →
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]Ой... ещё раз добавил случайно!!! Лажа вышла. :)
Страницы: 1 вся ветка
Форум: "WinAPI";
Текущий архив: 2003.08.25;
Скачать: [xml.tar.bz2];
Память: 0.46 MB
Время: 0.01 c