[serenberg]

Помогите пожалуйста!
в компонент timage загружена картинка
необходимо сделать аналог прямоугольного выделения фрагмента изображения (как в paint) линией и с запоминанием начальной и конечной точек координат данного выделения.

[Pilot_Red]

Что уже сделано, и что не понятно??

[serenberg]

считал координаты, но не знаю как нарисовать прозрачный прямоугольник, по зажатию клавиши мышки, т.к. с графикой не работал, но думаю разберусь на выходных, т.к. это не основная сейчас задача для работы.

[Pilot_Red]

если хошь нарисовать прозрачный прямоугольник, то присвой свойству
canvas.brush.style:=bsclear;

[poli-smen]

Сообщение от serenberg

Помогите пожалуйста!
в компонент timage загружена картинка
необходимо сделать аналог прямоугольного выделения фрагмента изображения (как в paint) линией и с запоминанием начальной и конечной точек координат данного выделения.

Пробуй так:

Код:

var
  SelRect: TRect; // В эту переменную запоминаются координаты выделенного прямоугольника

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    SelRect := Rect(X, Y, X, Y);
    Image1.Canvas.Pen.Style := psDashDot;
    Image1.Canvas.Pen.Mode := pmNot;
    Image1.Canvas.Brush.Style := bsClear;
  end;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if ssLeft in Shift then
  begin
    Image1.Canvas.Rectangle(SelRect);
    SelRect.BottomRight := Point(X, Y);
    Image1.Canvas.Rectangle(SelRect);
  end;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbLeft then
  begin
    Image1.Canvas.Rectangle(SelRect);
    SelRect.BottomRight := Point(X, Y);

    Image1.Canvas.Pen.Style := psSolid;
    Image1.Canvas.Pen.Mode := pmCopy;
    Image1.Canvas.Rectangle(SelRect);
    Image1.Canvas.Brush.Style := bsSolid;
  end;
end;

[Pyro]

можно через DrawFocusRect

Код:

var
  prevlasso, lasso: TRect;
  lassoStarted: boolean = false;

procedure Tmain.drawLasso(r: TRect);   // рисует/стирает рамку выделения
var rr: TRect;
begin
  rr.Left := min(r.Left, r.Right);
  rr.Top := min(r.Top, r.Bottom);
  rr.Right := max(r.Left, r.Right);
  rr.Bottom := max(r.Top, r.Bottom);
  main.Canvas.DrawFocusRect(rr);
end;

procedure Tmain.FormMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if not (ssleft in shift) then exit;

  lassoStarted := true;

  lasso.TopLeft := point(x, y);
  lasso.BottomRight := point(x, y);
  prevlasso := lasso;

  drawLasso(lasso);
end;

procedure Tmain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if not lassoStarted then exit;

  prevlasso := lasso;
  lasso.BottomRight := point(x, y);

  drawLasso(prevlasso);
  drawLasso(lasso);
end;

procedure Tmain.FormMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if not lassoStarted then exit;

  lassoStarted := false;

  prevlasso := lasso;
  drawLasso(prevlasso);

  if ssShift in Shift then
    ToggleSelectionOnThem
  else
    SelectThem;
end;

[serenberg]

Всем спасибо за помощь!

[poli-smen]

Сообщение от Pyro

можно через DrawFocusRect

Я тоже первоначально сделал через DrawFocusRect. Но из-за глюка этой функции, при которой она ничего не рисует если первая координата больше второй я решил не усложнять пример приведением координат к рабочему виду, которые у тебя выполняет метод drawLasso.
p.s. Мой первый пример сохранился, но приводить его не буду так как нет смысла - мой второй вариант мне нравится больше