Форум: "Основная";
Текущий архив: 2003.03.13;
Скачать: [xml.tar.bz2];
ВнизФорма (контуры) формы Найти похожие ветки
← →
Kair (2003-03-02 21:29) [0]Как сделать так, чтобы форма (контуры) формы принимала форму (контуры) рисунка в Image.
← →
Delphi5.01 (2003-03-02 21:48) [1]Na derji olni isxodnik! Zdes procedura kotoraia naxodit snachala region a potom sozdaiot formu na osnove etogo regiona, tolko zapomni odno no, u tvoego silueta ne doljno bit vistupov v tolshinu odin piksel a to proga zaciklivaetsa ne mojet naiti kontur etogo silueta
Procedure FindPixel(var x, y : Integer;
Pic : TImage);
var I, J : Integer;
begin
For I:=0 to Pic.Picture.Width-1 do
For J:=0 to Pic.Picture.Height-1 do
If Pic.Canvas.Pixels[I,J]<>Pic.Canvas.Pixels[0,0] then begin
X:=I;
Y:=J;
Exit;
end;
end;
Function CheckPixel(x, y : Integer;
Pic : TImage) : Boolean;
begin
CheckPixel:=False;
If (Pic.Canvas.Pixels[x,y-1]=Pic.Canvas.Pixels[0,0])and(Pic.Canvas.Pixels[x,y]<>Pic.Canvas.Pixels[0,0]) then CheckPixel:=True;
If (Pic.Canvas.Pixels[x+1,y]=Pic.Canvas.Pixels[0,0])and(Pic.Canvas.Pixels[x,y]<>Pic.Canvas.Pixels[0,0]) then CheckPixel:=True;
If (Pic.Canvas.Pixels[x,y+1]=Pic.Canvas.Pixels[0,0])and(Pic.Canvas.Pixels[x,y]<>Pic.Canvas.Pixels[0,0]) then CheckPixel:=True;
If (Pic.Canvas.Pixels[x-1,y]=Pic.Canvas.Pixels[0,0])and(Pic.Canvas.Pixels[x,y]<>Pic.Canvas.Pixels[0,0]) then CheckPixel:=True;
end;
Function Check(x, y : Integer;
var Pixel : array of TPoint;
Count : Integer): Boolean;
var i : Integer;
begin
Check:=True;
for i:=1 to Count-1 do
If (Pixel[i].x=x)and(Pixel[i].y=y) then Check:=false;
end;
//==========================================================
Procedure FindRegion(var Pixel : array of TPoint;
var CountOfPixel : Integer;
Pic : TImage);
var I, J : Integer;
Find : Boolean;
x, y : Integer;
begin
FindPixel(x,y,Pic);
CountOfPixel:=-1;
I:=X; J:=Y;
Repeat
Find:=False;
Inc(CountOfPixel);
If CheckPixel(I-1,J-1,Pic)and(Check(I-1,J-1,Pixel,CountOfPixel))and(Find=False) then begin
I:=I-1; j:=J-1; Find:=True;
Pixel[CountOfPixel].x:=i;
Pixel[CountOfPixel].y:=j;
end;
If CheckPixel(I,J-1,Pic)and(Check(I,J-1,Pixel,CountOfPixel))and(Find=False) then begin
I:=I; j:=J-1; Find:=True;
Pixel[CountOfPixel].x:=i;
Pixel[CountOfPixel].y:=j;
end;
If CheckPixel(I+1,J-1,Pic)and(Check(I+1,J-1,Pixel,CountOfPixel))and(Find=False) then begin
I:=I+1; j:=J-1; Find:=True;
Pixel[CountOfPixel].x:=i;
Pixel[CountOfPixel].y:=j;
end;
If CheckPixel(I+1,J,Pic)and(Check(I+1,J,Pixel,CountOfPixel))and(Find=False) then begin
I:=I+1; j:=J; Find:=True;
Pixel[CountOfPixel].x:=i;
Pixel[CountOfPixel].y:=j;
end;
If CheckPixel(I+1,J+1,Pic)and(Check(I+1,J+1,Pixel,CountOfPixel))and(Find=False) then begin
I:=I+1; j:=J+1; Find:=True;
Pixel[CountOfPixel].x:=i;
Pixel[CountOfPixel].y:=j;
end;
If CheckPixel(I,J+1,Pic)and(Check(I,J+1,Pixel,CountOfPixel))and(Find=False) then begin
I:=I; j:=J+1; Find:=True;
Pixel[CountOfPixel].x:=i;
Pixel[CountOfPixel].y:=j;
end;
If CheckPixel(I-1,J+1,Pic)and(Check(I-1,J+1,Pixel,CountOfPixel))and(Find=False) then begin
I:=I-1; j:=J+1; Find:=True;
Pixel[CountOfPixel].x:=i;
Pixel[CountOfPixel].y:=j;
end;
If CheckPixel(I-1,J,Pic)and(Check(I-1,J,Pixel,CountOfPixel))and(Find=False) then begin
I:=I-1; j:=J; Find:=True;
Pixel[CountOfPixel].x:=i;
Pixel[CountOfPixel].y:=j;
end;
Until (I=X) and (J=Y);
FindPixel(x,y,Pic);
Inc(CountOfPixel);
Pixel[CountOfPixel].x:=x;
Pixel[CountOfPixel].y:=y;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
Pixel : array [1..100000] of TPoint;
Count : Integer;
begin
Image1.Picture.LoadFromFile("forma.bmp");
FindRegion(Pixel,Count,Image1);
FormRGN:=CreatePolygonRgn(Pixel,Count,10);
SetWindowRgn(Handle,FormRgn,True);
end;
ne zabut fotku kinut "forma.bmp" (vistupi doljni bit bolshe chem odin piksel, procedura proverena na rabatasposobnost)!
FormRGN: HRGN;
P.S. a takje mojno delat formi s dirkami, prosto est takaia funqsia kak soedenenie dvux regionov, metodami and or i xor tak chto lez v win32.hlp i chitai, jelau udachi.
← →
Mihey (2003-03-02 22:26) [2]Действительно, все подобные штуки делают на регионах. Могу дать процедурку попроще и для любого окна:
procedure CropWindow( Handle: HWnd; Picture : TPicture );
var
hrgn, hrgn1 : integer;
hdc : integer;
x, y : integer;
Color : TColor;
begin
// Color := Picture.Bitmap.Canvas.Pixels[ 0, 0 ];
Color := clWhite;
hdc := GetDC( Handle );
hrgn := CreateRectRgn( 0, 0, Picture.Graphic.Width, Picture.Graphic.Height );
for x := 1 to Picture.Graphic.Width do
for y := 1 to Picture.Graphic.Height do
if Picture.Bitmap.Canvas.Pixels[ x - 1, y - 1 ] = Color then begin
hrgn1 := CreateRectRgn( x - 1, y - 1, x, y);
CombineRgn( hrgn, hrgn, hrgn1, RGN_DIFF );
DeleteObject( hrgn1 );
end;
SetWindowRgn( Handle, hrgn, true );
//DeleteObject( hrgn );
ReleaseDC( Handle, hdc);
end;
procedure UncropWindow( Handle: HWnd; Picture : TPicture );
var
hrgn : integer;
hdc : integer;
begin
hdc := GetDC( Handle );
hrgn := CreateRectRgn( 0, 0, Picture.Graphic.Width , Picture.Graphic.Height );
SetWindowRgn( Handle, hrgn, true );
ReleaseDC( Handle, hdc );
end;
← →
Delphi5.01 (2003-03-03 00:39) [3]Kruto mne ponravilos! :-)))
Страницы: 1 вся ветка
Форум: "Основная";
Текущий архив: 2003.03.13;
Скачать: [xml.tar.bz2];
Память: 0.46 MB
Время: 0.007 c