Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Основная";
Текущий архив: 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.56 MB
Время: 0.041 c
7-39613
TankMan1
2002-11-14 00:04
2003.03.13
Как отменить удаление файла с винта...


14-39524
trotski
2003-02-25 22:20
2003.03.13
Оформление документации


7-39592
edicon
2003-01-11 01:57
2003.03.13
Программирование Com-порта


7-39593
AuX
2002-12-18 21:59
2003.03.13
Смена IP сетевухи в винь без перезагруза машины.


3-39203
Nick2000
2003-02-20 19:56
2003.03.13
Поиск и сортировка





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