Масштабирование компонентов Опции

[Unconnected]

Привет всем.

На форме имеются созданные вручную TImage'и. Каждому я вручную присвоил необходимые события. Собственно, нужно сделать возможность изменения размеров компонента, чтобы при подводе курсора к границе (но не к углу!) имаджа курсор менялся на обоюдоострую стрелочку, и можно было растягивать компонент. Вот что получилось:

Procedure TLine_Road.onMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  xmouse:=x;ymouse:=y;
  down:=true;
end;

Procedure TLine_Road.onMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  down:=false;
end;

Procedure TLine_Road.OnMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
var m:TImage;
begin
  m:=(sender as TImage);
  if (x>m.left) and (x<m.left+m.width) and ((y=m.top) or (y=m.top+m.height)) then
    begin
      m.Cursor:=crSizeNS;
      if down then begin
        if y=m.top then begin
                          m.height:=m.height+(y-m.top);
                          m.Top:=y-1;
                        end;
      end;
    end else
  if down then
  begin
    m.Cursor:=crDefault;
    m.left:=m.left+(x-xmouse);
    m.top:=m.top+(y-ymouse);
  end;
end;

В процедуре OnMove я уже сделал перетаскивание компонента, работает. А вот чуть выше, в этой процедуре - попытка сделать ресайз, но там пробно только для верхней границы. Какое-то странное поведение: имадж создаётся на панели с координатами (1,1), уже с картинкой. Если его не двигать, то при подводе курсора к верхней границе, он, курсор, меняет, как и должно быть, форму, но ничего не меняет. А если имадж подвинуть ниже, то и вовсе курсор не меняется. Подвинули на исходную - меняется. Чертовщина, хотя сравнивал координаты - вроде правильно всё.

Сообщение отредактировано: Unconnected - 22.02.2010 20:26

[volvo]

OnMove - это что? Какое сообщение обрабатывается?

[Unconnected]

OnMouseMove, и с остальными так же.

И ещё, у имаджей свойства autosize и stretch стоят в true.

Сообщение отредактировано: Unconnected - 22.02.2010 20:56

[volvo]

А собственно, с чего ты решил, что TImage.OnMouseMove дает тебе X, Y, как-то относящиеся к внешним компонентам? X, Y как раз изменяются 1 .. m.Width, 1 .. m.Height соответственно. Если мыша вне контрола - событие просто не наступает. Это по поводу твоего удивления

А если имадж подвинуть ниже, то и вовсе курсор не меняется.

Теперь понятно, почему?

Я бы решал задачу вот так:

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  xmouse:=x;ymouse:=y;
  down:=true;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
type
  TMyStatus = (stMoving, stResizing);
var
  m:TImage;
  myStatus: TMyStatus;
begin
  m:=(sender as TImage);

  if (x >= 1) and (x <= m.Width) and ((y = 1) or (y = m.Height-1)) then
  begin
    m.Cursor:=crSizeNS;
    myStatus := stResizing;
  end
    else
      if PtInRect(Rect(2, 2,  m.Width - 2, m.Height - 2), Point(X, Y)) then
      begin
        m.Cursor := crHandPoint; myStatus := stMoving;
      end;

  if down then
  case myStatus of
    stMoving:
    begin
      m.left:=m.left+(x-xmouse);
      m.top:=m.top+(y-ymouse);
    end;
    stResizing:
    begin
      // Тут твои действия по ресайзу изображения...
    end;
  end;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  down := false;
end;

(для большей правдоподобности курсор устанавливается в Hand, когда можно перетаскивать изображение)

[Unconnected]

Код интересный, спасибо, повожусь с ним

[Unconnected]

Во дела. Ресайз не работал, пока я не отключил AutoSize! Но, когда я отключил AutoSize, то картинка сразу потолстела и стала некрасивой (у меня ещё strength включён). Можно ли это как-то обойти, не запрашивая размеры файла-картинки и не забивая их вручную в имадж при его создании?

[volvo]

Proportional в True устанавливать не пробовал?

[Unconnected]

В итоге я сделал массивом из размеров, они мне ещё понадобятся.. Теперь с именно ресайзом косяк:

Procedure TLine_Road.OnMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
type
  TMyStatus = (stMoving, stResizing);
var
  m:TImage;
  myStatus: TMyStatus;
begin
  m:=(sender as TImage);
  if (x > 1) and (x < m.Width) and ((y = 1) or (y = m.Height-1)) then
  begin
    m.Cursor:=crSizeNS;
    myStatus:=stResizing;
  end
    else
      if PtInRect(Rect(2,2,m.Width-2,m.Height-2),Point(X,Y)) then
      begin
        m.Cursor:=crHandPoint;
        myStatus:=stMoving;
      end;
  if down then
  case myStatus of
    stMoving:
    begin
      m.left:=m.left+(x-xmouse);
      m.top:=m.top+(y-ymouse);
    end;
    stResizing:
    begin
      m.height:=m.Height+1; //<-
    end;
  end;
end;

Сделал экспериментально только для растягивания вниз. Так-то механизм я понял, но вот этот код работает только когда растягиваешь медленно-медленно...

[volvo]

Хочешь, покажу тебе "уличную магию"?

Выносишь тип и переменную за пределы обработчика события, и чуть-чуть перегруппируешь операторы в самом обработчике:

type
  TMyStatus = (stMoving, stResizing);
var
  myStatus: TMyStatus;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  m: timage;
begin
  m := sender as TImage;
  if not down then begin

    if (x >= 1) and (x <= m.Width) and ((y = 1) or (y = m.Height - 1)) then
    begin
      m.Cursor:=crSizeNS;
      myStatus := stResizing;
    end
    else
      if PtInRect(Rect(2, 2,  m.Width - 2, m.Height - 2), Point(X, Y)) then
      begin
        m.Cursor := crHandPoint; myStatus := stMoving;
      end;

  end
  else begin

    case myStatus of
      stMoving:
      begin
        m.left:=m.left+(x-xmouse);
        m.top:=m.top+(y-ymouse);
      end;
      stResizing:
      begin
        m.height:=m.Height+1; //<-
      end;
    end;

  end;
end;

, и теперь оно работает (только на увеличение, однако; у тебя же независимо от направления движения мыши высота изображения увеличивается) при любой скорости перемещения мыши.

[Unconnected]

Уже лучше стало, уличная магия заключалась в " if not down then begin" (помимо глобализации типа и переменной)?

Только вот со скоростью мышки всё равно не так получается. Если веду со средней скоростью - нормально, а чуть быстрее - курсор улетает с нижней границы. В принципе, ресайз и так состоится, но некрасиво как-то) небольшое видео прикрепил.

[volvo]

Попробуй сделать так, чтоб мыша вылезла за пределы контрола вот с таким Case-ом:

    case myStatus of
      stMoving:
      begin
        m.left:=m.left+(x-xmouse);
        m.top:=m.top+(y-ymouse);
      end;
      stResizing:
      begin
        m.height:=m.Height + (y-ymouse); // <- раз 
        ymouse := y; // <-- два
      end;
    end;

Удачи тебе ...

[Rian]

вот такое тож работает, правда курсоры не делал

 x1,y1,s:integer;

implementation

{$R *.dfm}

procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
x1:=x; y1:=y;
 move:=true;
 if x<5 then s:=1 else
 if y<5 then s:=2 else
 if x>(image1.Width-5) then s:=3;
 if y>(image1.height-5)then s:=4;
end;

procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
move:=false;
s:=0;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
  if move then
  case s of
  1:begin
    image1.Left:=image1.Left-(x1-x);
    image1.width:=image1.width+(x1-x);
    end;
  2:begin
    image1.top:=image1.top-(y1-y);
    image1.height:=image1.height+(y1-y);
    end;
  3:begin
  x1:=image1.Width;
    image1.width:=image1.width-(x1-x);
    end;
  4:begin
  y1:=image1.height;
    image1.height:=image1.height-(y1-y);
    end;
  else
  image1.Left:=image1.Left-(x1-x);
  image1.top :=image1.top -(y1-y);
  end;
end;

[volvo]

вот такое тож работает

Работать и работать правильно - это разные вещи... Твой код - работает...

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

Добавлено через 4 мин.
P.S. Кстати, а вот это:

  else
  image1.Left:=image1.Left-(x1-x);
  image1.top :=image1.top -(y1-y);

к чему относится? Это был первый вопрос на засыпку. А второй - как ты думаешь, когда отработает изменение Image1.Top? При каких условиях?

[Client]

Набрал код Rian'а (ренейм? ) и скачков не заметил. Правда, морагние есть небольшое

к чему относится

Методом трассировки выяснил, что этот код отвечает за перемещение имеджа при нажатии мыши в области, не включающую в себя рамку

PtInRect(Rect(2, 2,  m.Width - 2, m.Height - 2), Point(X, Y))

Это "point in rect" ? т.е. область не влючая рамку (2 пикселя) ?

Добавлено через 2 мин.

Хочешь, покажу тебе "уличную магию"?

Не-не-не, только не это, Дэвид Блэйн

[Rian]

Набрал код Rian'а (ренейм? ) и скачков не заметил. Правда, морагние есть небольшое

моргание убирается через
doublebufferd:=true;

ренейм) не может же первый придуманный ник быть вечным....

Добавлено через 12 мин.

Работать и работать правильно - это разные вещи... Твой код - работает...

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

Добавлено через 4 мин.
P.S. Кстати, а вот это:
к чему относится? Это был первый вопрос на засыпку. А второй - как ты думаешь, когда отработает изменение Image1.Top? При каких условиях?

убегает с космической скоростью?... не заметил....

последняя проверка перемещает всю картинку

image1.top отработает если y<5 и... есть флаг нажатия

ЗЫ. я уже боюсь чего это volvo опять загадает

[volvo]

скачков не заметил

Я про скачки не говорил я говорил про непропорционально высокую по сравнению со скоростью перемещения мыши скорость:
 resize.zip ( 712.12 килобайт ) Кол-во скачиваний: 292


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

Добавлено через 1 мин.

последняя проверка перемещает всю картинку

Последняя проверка записана некорректно - Else относится только к ПРЕДпоследней проверке, если ты не заметил. Операторных скобок не было замечено в твоем коде. Или это опять я не прав, а у тебя все шоколадно?

[Rian]

Это что, мне только кажется, или так и должно быть? Тогда я больше в эту тему не захожу, вы скажите, если я тут мешаю ...

не не не ни в коем случае!

может в свойствах картинки что-то другое?
но у меня код таскает, все как положено: все границы и вся картинка
Else относится к case а что не так?

Сообщение отредактировано: Rian - 24.02.2010 18:22

[Client]

если я тут мешаю

Ну с чего такие мысли? тебе тут все рады

Сообщение отредактировано: Client - 24.02.2010 18:49

[Unconnected]

Если кому интересно, вот немного модифицированный код volvo, немного расширена область "рамки" для ресайза, и разделение на ресайз вверх и вниз (право-лево мне не надо):

TMyStatus = (stMoving, stResizing);
var 
    myStatus: TMyStatus;
    up,downer:boolean;

Procedure TLine_Road.OnMouseLeave(Sender: TObject);
begin
  down:=false;downer:=false;up:=false;
  (sender as TImage).Cursor:=crDefault;
end;

Procedure TLine_Road.onMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  xmouse:=x;ymouse:=y;
  down:=true;
end;

Procedure TLine_Road.onMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  down:=false;
end;

procedure TLine_Road.onMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
  m: timage;
  buf:integer;
begin
  m:=sender as TImage;
  if not down then begin
    if (x>=1) and (x <= m.Width) and ((y <= 3) or (y >= m.Height - 3)) then
    begin
      m.Cursor:=crSizeNS;
      myStatus := stResizing;
      if y<=3 then begin
                     up:=true;
                     downer:=false;
                   end else if (y>=m.height-3) then begin
                     up:=false;
                     downer:=true;
                   end;
    end
    else
      if PtInRect(Rect(4, 4,  m.Width -4, m.Height - 4), Point(X, Y)) then
      begin
        m.Cursor := crHandPoint; myStatus := stMoving;
      end;
  end
  else
  begin
    case myStatus of
      stMoving:
      begin
        m.left:=m.left+(x-xmouse);
        m.top:=m.top+(y-ymouse);
      end;
      stResizing:
      begin
        buf:=m.top;
        if downer then begin
          m.height:=m.Height+(y-ymouse);
          ymouse:=y;
        end else begin
          m.top:=m.top-(ymouse-y);
          m.height:=m.height+(ymouse-y);
        end;
      end;
    end;
  end;
end;

sorry за мой английский)

Сообщение отредактировано: Unconnected - 24.02.2010 23:02

[Гость]

да кстати а чем видео делаете?