How allow user to select part of image and copy it to file ?

[seba22]

Welcome,

I would ask  a question.

How can I allow in my application to select part of image and copy selected area to new file ?

Is there any component what allow action like this one ?

I mean, i would like open picture saved in c:\test.jpg
And display it to user. User should select part (RECTANGLE) of that image and click copy.
Then it should save selected area.

I was never trying to something like that that's why i don't know where i should look.

In Delphi i can remember there was option called   Image.Canvas.CopyRect but i have input  dimensions, i mean location of my rectangle.
How Can i get that rectangle from user ?


Regards

[garlar27]

You can use a TImage in the form and catch coordinates from the
MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer) and
MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer)
events to get coordinates start and end coordinates to use in the CopyRect.

[seba22]

Welcome,

Few days ago i ask question about copying part of image.

Today i would like show you some code, and ask... why it's not working well

First screenshot working application...
http://photoadder.com/show-image.php?id=168729d2ac78ec19afad3bc0274bfdb1

but, when i start drawing my rectangle from bottom right to top it looks like that

http://photoadder.com/show-image.php?id=9589b27b8098453df044c5f8441e4b47


Any idea, how can i make it working (allow user to select, like he want, from any direction )

I attach sourcecode

Code: [Select]

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
  ExtCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    Image: TImage;
    Image2: TImage;
    procedure FormCreate(Sender: TObject);
    procedure ImageMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer
      );
    procedure ImageMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;
    Drawing : boolean ;
    P : TPoint ;
    P2 : TPoint ;
implementation

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  Drawing := False ;
end;

procedure TForm1.ImageMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Drawing := True ;


P := Point(X, Y) ;
P2 := P ;
Image.Canvas.Pen.Color := clRed ;  // color 'pen'
Image.Canvas.Brush.Style := bsClear ; // 'remove'
Image.Canvas.Pen.Style := psDashDot ; // dotted dash
Image.Picture.LoadFromFile('/home/laboratory2/Desktop/test.bmp');
end;

procedure TForm1.ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if Drawing = true then
 begin
Image.Canvas.Pen.Mode := pmNotXor ;
Image.Canvas.Rectangle(P.X, P.Y, P2.X, P2.Y);
P2.X := X ;
P2.Y := Y ;
Image.Canvas.Pen.Mode := pmNotXor ;
Image.Canvas.Rectangle(P.X, P.Y, P2.X, P2.Y);
 end;
end;

procedure TForm1.ImageMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
 B: TBitmap ;
begin
Drawing := False ;
B := TBitmap.Create ;
 B.Width := Abs(P2.X - P.X);
  B.Height := Abs(P2.Y - P.Y);
  B.Canvas.CopyRect(Rect(0, 0, b.Width, b.Height), Image.Canvas,
    Rect(P.X, P.Y, P2.X, P2.Y));
    Image2.width:=Abs(P2.X - P.X);
    Image2.height:=Abs(P2.Y - P.Y);

  Image2.Canvas.Draw(0, 0, B);

//B.SaveToFile('C:\somthing.bmp');
end;

initialization
  {$I unit1.lrs}

end.

 

Regards

[typo]

Use Canvas.DrawFocusRect;

[seba22]

I rewrited it to use DrawFocusRect but still not solve my problem with copying selected part...
from left to right working, from right to left = fail.

Code: [Select]

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, FileUtil, LResources, Forms, Controls, Graphics, Dialogs,
  ExtCtrls;

type

  { TForm1 }

  TForm1 = class(TForm)
    Image: TImage;
    Image2: TImage;
    procedure FormCreate(Sender: TObject);
    procedure ImageMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer
      );
    procedure ImageMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { private declarations }
  public
    { public declarations }
  end;

var
  Form1: TForm1;
    Drawing : boolean ;
    P : TPoint ;
    P2 : TPoint ;
implementation

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  Drawing := False ;
end;

procedure TForm1.ImageMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Drawing := True ;


P := Point(X, Y) ;
P2 := P ;
  Image.Canvas.DrawFocusRect(Rect(x, y, x, y));
Image.Picture.LoadFromFile('/home/laboratory2/Desktop/test.bmp');
end;

procedure TForm1.ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if Drawing = true then
 begin
    Image.Canvas.DrawFocusRect(Rect(P.x, P.y, P2.x,P2.y));
    P2 := Point(x, y);
    Image.Canvas.DrawFocusRect(Rect(P.x, P.y, x, y));


 end;
end;

procedure TForm1.ImageMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var
 B: TBitmap ;
 Bitmapa:TBitmap;

begin

  Image.Canvas.DrawFocusRect(Rect(P.x, P.y, P2.x, P2.y));
  Image.Canvas.DrawFocusRect(Rect(P.x, P.y, x, y));
  //P := Point(x, y);


Drawing := False ;

B := TBitmap.Create ;
B.Width := Round(abs(P2.x - P.x));
B.Height := Round(abs(P2.y - P.y));
B.Canvas.CopyRect(Rect(0, 0, b.Width, b.Height), Image.Canvas,
Rect(P.X, P.Y, P2.X, P2.Y));
Image2.Width := Round(abs(P2.x - P.x));
Image2.Height := Round(abs(P2.y - P.y));
 // showmessage(inttostr(B.Width));
  //  showmessage(inttostr(B.height));

Image2.Canvas.Draw(0, 0, B);




//B.SaveToFile('C:\somthing.bmp');
end;

initialization
  {$I unit1.lrs}

end.


[seba22]

I almost done

Code: [Select]

if (P.x>P2.x) then
 begin
 t1:=P.x;
 P.x:=P2.x;
 P2.x:=t1;
 end;
 if (P.y>P2.y) then
 begin
 t2:=P.y;
 P.y:=P2.y;
 P2.y:=t1;
 end; 
But application crash, when i select from bottom left to top right.
In any other way, working well.

[typo]

This code should work:

Code: [Select]

var
  md :boolean = False;
  p1, p2 :TPoint;
  r, SelRect :TRect;
procedure TForm1.FormMouseDown(Sender:TObject;Button:TMouseButton;Shift:
  TShiftState;X,Y:Integer);
begin
  if selrect.Left <> 0 then
  begin
    Canvas.Pen.Mode:= pmMask;
    Canvas.DrawFocusRect(SelRect);
    with selrect do
    begin
      Left := 0;
      Top := 0;
      Right := 0;
      Bottom := 0;
    end;
  end;

  p1.x := x;
  p1.y := y;
  md := True;
end;

procedure TForm1.FormMouseMove(Sender:TObject;Shift:TShiftState;X,Y:Integer);
var
  pp :TPoint;
begin
  if not md then Exit;

  // erase old rectangle
  r.Top := p1.y;
  r.Left := p1.x;
  r.Right := p2.x;
  r.Bottom := p2.y;
  Canvas.pen.mode := pmMask;
  if (p1.x<>0)and(p2.x<>0)then
  if (p2.x>p1.x) then
    Canvas.DrawFocusRect(r)
  else
    Canvas.DrawFocusRect(rect(p2.x,p2.y,p1.x,p1.y));

  // draw new rectangle
  p2.x := x;
  p2.y := y;
  r.Top := p1.y;
  r.Left := p1.x;
  r.Right := p2.x;
  r.Bottom := p2.y;
  Canvas.Pen.Mode := pmCopy;
  if (p1.x<>0)and(p2.x<>0)then
  if (p2.x>p1.x) then
    Canvas.DrawFocusRect(r)
  else
    Canvas.DrawFocusRect(rect(p2.x,p2.y,p1.x,p1.y));
end;

procedure TForm1.FormMouseUp(Sender:TObject;Button:TMouseButton;Shift:
  TShiftState;X,Y:Integer);
begin
  r.Top := p1.y;
  r.Left := p1.x;
  r.Right := p2.x;
  r.Bottom := p2.y;
  {
  // erase old rectangle
  Canvas.Pen.Mode:= pmMask;
  if (p1.x<>0)and(p2.x<>0)then
  if (p2.x>p1.x) then
    Canvas.DrawFocusRect(r)
  else
    Canvas.DrawFocusRect(Rect(p2.x,p2.y,p1.x,p1.y));
  }
  with selrect do
  if p1.x <p2.x then
  begin
    Left := p1.x;
    Top := p1.y;
    Right := p2.x;
    Bottom := p2.y;
  end
  else
  begin
    Left := p2.x;
    Top := p2.y;
    Right := p1.x;
    Bottom := p1.y;
  end;

  md := False;
  p1.x := 0;
  p1.y := 0;
  p2.x := 0;
  p2.y := 0;
end;   

[seba22]

Code: [Select]

Thanks,

When i was reading Your code i realize what's going wrong in my ;)

 if (P.y>P2.y) then
 begin
 t2:=P.y;
 P.y:=P2.y;
 P2.y:=t1;
 end;
i assign t1... it should be t2.

Code: [Select]

Thanks,

When i was reading Your code i realize what's going wrong in my ;)

 if (P.y>P2.y) then
 begin
 t2:=P.y;
 P.y:=P2.y;
 P2.y:=tt;
 end;
Small mistake... i spend few hours trying to find what's wrong.

Thank You

[typo]

I have edited the code a bit.