Эксперт
Профиль
Группа: Участник Клуба
Сообщений: 1198
Регистрация: 3.5.2003
Репутация: 13
Всего: 63
|
| Цитата |
Как из компонента TImage вырезать(скопировать) областью выделения и переместить в другой TImage
|
Т.е. резиновым прямоуголиньком? Имеется в виду что-то наподоби crop'a? Я бы тут забил на TImage и делал свой компонент, но раз уж сильно хочется TImage, то ложим на форку 2 TImage, в один из них засовываем TBitmap и пишем: | Код |
var
Form1: TForm1;
bp, ep : TPoint;
downed : boolean = false;
implementation
{$R *.dfm}
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
downed:=true;
bp:=point(x,y);
ep:=point(x,y);
SetCapture(Form1.Handle);
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if downed then
begin
with Image1.Canvas do
begin
Pen.Style := psDot;
Pen.Color := clGray;
Pen.Mode := pmXor;
Brush.Style := bsClear;
Rectangle(bp.x, bp.y, ep.x, ep.y);
end;
ep:=point(x,y);
with Image1.Canvas do
begin
Pen.Style := psDot;
Pen.Color := clGray;
Pen.Mode := pmXor;
Brush.Style := bsClear;
Rectangle(bp.x, bp.y, ep.x, ep.y);
end;
end;
end;
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
downed:=false;
with Image1.Canvas do
begin
Pen.Style := psDot;
Pen.Color := clGray;
Pen.Mode := pmXor;
Brush.Style := bsClear;
Rectangle(bp.x, bp.y, ep.x, ep.y);
end;
Image2.Picture.Bitmap:=TBitmap.Create;
Image2.Picture.Bitmap.Width:=abs(bp.X-ep.X);
Image2.Picture.Bitmap.Height:=abs(bp.y-ep.y);
Image2.Picture.Bitmap.Canvas.CopyRect(Rect(0,0,Image2.Picture.Bitmap.Width,Image2.Picture.Bitmap.Height),Image1.Picture.Bitmap.Canvas,Rect(bp.X,bp.Y,ep.X,ep.y));
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
self.DoubleBuffered:=true;
end;
|
| Цитата |
четыре копии исправив разрешение и размеры изображения ( точно сходные с печатью на бумаге)
|
а также | Цитата |
Как изменить размеры изображения
|
| Код |
type
TMargins = record
Left,
Top,
Right,
Bottom: Double
end;
type TXSize = record
Width, Height : Extended
end;
procedure Interpolate(x, y, Width, Height : Integer; Rect : TRect; var S, D : TBitmap);
var
z1, z2: single;
k: single;
i, j: integer;
dw,dh, xo, yo: integer;
x1r,y1r : extended;
Xs, Xd : array of PARGB;
dx, dy : Extended;
begin
S.PixelFormat:=Pf24bit;
D.PixelFormat:=Pf24bit;
D.Width:=Math.Max(D.Width,x+Width);
D.height:=Math.Max(D.height,y+Height);
dw:=Math.Min(D.Width-x,x+Width);
dh:=Math.Min(D.height-y,y+Height);
dx:=(Width)/(Rect.Right-Rect.Left-1);
dy:=(Height)/(Rect.Bottom-Rect.Top-1);
if (dx<1) or (dy<1) then exit;
SetLength(Xs,S.Height);
for i:=0 to S.Height - 1 do
Xs[i]:=S.scanline[i];
SetLength(Xd,D.Height);
for i:=0 to D.Height - 1 do
Xd[i]:=D.scanline[i];
for i := 0 to min(Round((Rect.Bottom-Rect.Top-1)*dy)-1,dh-1) do begin
yo := Trunc(i / dy)+Rect.Top;
y1r:= Trunc(i / dy) * dy;
if yo+1>=S.height then Break;
for j := 0 to min(Round((Rect.Right-Rect.Left-1)*dx)-1,dw-1) do begin
xo := Trunc(j / dx)+Rect.Left;
x1r:= Trunc(j / dx) * dx;
if xo+1>=S.Width then Continue;
begin
z1 := ((Xs[yo ,xo+ 1].r - Xs[yo,xo].r)/ dx)*(j - x1r) + Xs[yo,xo].r;
z2 := ((Xs[yo+1,xo+1].r - Xs[yo+1,xo].r) / dx)*(j - x1r) + Xs[yo+1,xo].r;
k := (z2 - z1) / dy;
Xd[i+y,j+x].r := Round(i * k + z1 - y1r * k);
z1 := ((Xs[yo ,xo+ 1].g - Xs[yo,xo].g)/ dx)*(j - x1r) + Xs[yo,xo].g;
z2 := ((Xs[yo+1,xo+1].g - Xs[yo+1,xo].g) / dx)*(j - x1r) + Xs[yo+1,xo].g;
k := (z2 - z1) / dy;
Xd[i+y,j+x].g := Round(i * k + z1 - y1r * k);
z1 := ((Xs[yo ,xo+ 1].b - Xs[yo,xo].b)/ dx)*(j - x1r) + Xs[yo,xo].b;
z2 := ((Xs[yo+1,xo+1].b - Xs[yo+1,xo].b) / dx)*(j - x1r) + Xs[yo+1,xo].b;
k := (z2 - z1) / dy;
Xd[i+y,j+x].b := Round(i * k + z1 - y1r * k);
end;
end;
end;
end;
procedure StretchCool(x, y, Width, Height : Integer; var S, D : TBitmap);
var
i,j,k,p,Sheight1:integer;
p1: pargb;
col,r,g,b : integer;
Sh, Sw : Extended;
Xp : array of PARGB;
begin
s.PixelFormat:=pf24bit;
d.PixelFormat:=pf24bit;
if width+x>d.Width then
d.Width:=width+x;
if Height+y>d.Height then
d.Height:=height+y;
Sh:=S.height/height;
Sw:=S.width/width;
Sheight1:=S.height-1;
SetLength(Xp,S.height);
for i:=0 to Sheight1 do
Xp[i]:=s.ScanLine[i];
for i:=Math.Max(0,y) to height+y-1 do
begin
p1:=d.ScanLine[i];
for j:=0 to width-1 do
begin
col:=0;
r:=0;
g:=0;
b:=0;
for k:=Round(Sh*(i-y)) to Min(S.Height-1,Round(Sh*(i+1-y))-1) do
begin
for p:=Round(Sw*j) to Min(Round(Sw*(j+1))-1,S.Width-1) do
begin
inc(col);
inc(r,Xp[k,p].r);
inc(g,Xp[k,p].g);
inc(b,Xp[k,p].b);
end;
end;
if (col<>0) and (j+x>0) then
begin
p1[j+x].r:=r div col;
p1[j+x].g:=g div col;
p1[j+x].b:=b div col;
end;
end;
end;
end;
function XSize(Width,Height : extended) : TXSize;
begin
Result.Width:=Width;
Result.Height:=Height;
end;
function MmToPix(Size : TXSize) : TXSize;
var
Inch, PixelsPerInch : TXSize;
begin
PixelsPerInch:=GetPixelsPerInch;
Inch.Width:=CmToInch(Size.Width/10);
Inch.Height:=CmToInch(Size.Height/10);
Result.Width:=Inch.Width*PixelsPerInch.Width;
Result.Height:=Inch.Height*PixelsPerInch.Height;
end;
function PixToSm(Size : TXSize) : TXSize;
var
Inch, PixelsPerInch : TXSize;
begin
PixelsPerInch:=GetPixelsPerInch;
Inch.Width:=Size.Width/PixelsPerInch.Width;
Inch.Height:=Size.Height/PixelsPerInch.Height;
Result.Width:=InchToCm(Inch.Width);
Result.Height:=InchToCm(Inch.Height);
end;
function PixToIn(Size : TXSize) : TXSize;
var
Inch, PixelsPerInch : TXSize;
begin
PixelsPerInch:=GetPixelsPerInch;
Result.Width:=Size.Width/PixelsPerInch.Width;
Result.Height:=Size.Height/PixelsPerInch.Height;
end;
procedure ProportionalSize(aWidth, aHeight: Integer; var aWidthToSize, aHeightToSize: Integer);
begin
// If Max(aWidthToSize,aHeightToSize)<Min(aWidth,aHeight) then
{ If (aWidthToSize<aWidth) and (aHeightToSize<aHeight) then
begin
Exit;
end; }
if aWidthToSize*aWidth=0 then exit;
if (aWidthToSize = 0) or (aHeightToSize = 0) then
begin
aHeightToSize := 0;
aWidthToSize := 0;
end else begin
if (aHeightToSize/aWidthToSize) < (aHeight/aWidth) then
begin
aHeightToSize := Round ( (aWidth/aWidthToSize) * aHeightToSize );
aWidthToSize := aWidth;
end else begin
aWidthToSize := Round ( (aHeight/aHeightToSize) * aWidthToSize );
aHeightToSize := aHeight;
end;
end;
end;
procedure GetPrinterMargins(var Margins: TMargins);
var
PixelsPerInch: TPoint;
PhysPageSize: TPoint;
OffsetStart: TPoint;
PageRes: TPoint;
begin
PixelsPerInch.y := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
PixelsPerInch.x := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
Escape(Printer.Handle, GETPHYSPAGESIZE, 0, nil, @PhysPageSize);
Escape(Printer.Handle, GETPRINTINGOFFSET, 0, nil, @OffsetStart);
PageRes.y := GetDeviceCaps(Printer.Handle, VERTRES);
PageRes.x := GetDeviceCaps(Printer.Handle, HORZRES);
// Top Margin
Margins.Top := OffsetStart.y / PixelsPerInch.y;
// Left Margin
Margins.Left := OffsetStart.x / PixelsPerInch.x;
// Bottom Margin
Margins.Bottom := ((PhysPageSize.y - PageRes.y) / PixelsPerInch.y) -
(OffsetStart.y / PixelsPerInch.y);
// Right Margin
Margins.Right := ((PhysPageSize.x - PageRes.x) / PixelsPerInch.x) -
(OffsetStart.x / PixelsPerInch.x);
end;
function InchToCm(Pixel: Single): Single;
// Convert inch to Centimeter
begin
Result := Pixel * 2.54
end;
function CmToInch(Pixel: Single): Single;
// Convert Centimeter to inch
begin
Result := Pixel / 2.54
end;
function GetPixelsPerInch : TXSize;
begin
Result.Height := GetDeviceCaps(Printer.Handle, LOGPIXELSY);
Result.Width := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
end;
procedure CropImageOfHeight(CroppedHeight : Integer; var Bitmap : TBitmap);
var
i,j, dy : integer;
Xp : array of PARGB;
aWidth, aHeight : integer;
begin
Bitmap.PixelFormat:=pf24bit;
SetLength(Xp,Bitmap.height);
if Bitmap.Height*Bitmap.Width=0 then exit;
if CroppedHeight=Bitmap.Height then exit;
for i:=0 to Bitmap.Height-1 do
Xp[i]:=Bitmap.ScanLine[i];
dy:=Bitmap.Height div 2 - CroppedHeight div 2;
for i:=0 to CroppedHeight-1 do
for j:=0 to Bitmap.Width-1 do
begin
Xp[i,j]:=Xp[i+dy,j];
end;
Bitmap.Height:=CroppedHeight;
end;
procedure CropImageOfWidth(CroppedWidth : Integer; var Bitmap : TBitmap);
var
i,j, dx : integer;
Xp : array of PARGB;
aWidth, aHeight : integer;
begin
Bitmap.PixelFormat:=pf24bit;
SetLength(Xp,Bitmap.height);
if Bitmap.Height*Bitmap.Width=0 then exit;
if CroppedWidth=Bitmap.Width then exit;
for i:=0 to Bitmap.Height-1 do
Xp[i]:=Bitmap.ScanLine[i];
dx:=Bitmap.Width div 2 - CroppedWidth div 2;
for i:=0 to Bitmap.Height-1 do
for j:=0 to CroppedWidth do
begin
Xp[i,j]:=Xp[i,j+dx];
end;
Bitmap.Width:=CroppedWidth;
end;
procedure CropImage(aWidth, aHeight : Integer; var Bitmap : TBitmap);
var
temp : Integer;
begin
if aHeight=0 then exit;
if (((aWidth/aHeight)>1) and ((Bitmap.Width/Bitmap.Height)<1)) or
(((aWidth/aHeight)<1) and ((Bitmap.Width/Bitmap.Height)>1)) then
begin
temp:=aWidth;
aWidth:=aHeight;
aHeight:=temp;
end;
if Bitmap.Width/Bitmap.Height<aWidth/aHeight then
begin
CropImageOfHeight(Round(Bitmap.Width*(aHeight/aWidth)),Bitmap);
end else
begin
CropImageOfWidth(Round(Bitmap.Height*(aWidth/aHeight)),Bitmap);
end;
end;
|
а потом сохранить это изображение Все наследники TGraphic имеют один забавный метод - SaveToFile.
|
Работа с изображением, Изменение размеров и разрешения 
Загрузка ...
