Форум: "Основная";
Текущий архив: 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.01 c