Мастера DELPHI, Delphi programming community Рейтинг@Mail.ru Титульная страница Поиск, карта сайта Написать письмо 
| Новости |
Новости сайта
Поиск |
Поиск по лучшим сайтам о Delphi
FAQ |
Огромная база часто задаваемых вопросов и, конечно же, ответы к ним ;)
Статьи |
Подборка статей на самые разные темы. Все о DELPHI
Книги |
Новинки книжного рынка
Новости VCL
Обзор свежих компонент со всего мира, по-русски!
|
| Форумы
Здесь вы можете задать свой вопрос и наверняка получите ответ
| ЧАТ |
Место для общения :)
Орешник
Коллекция курьезных вопросов из форумов
Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / rsdn.org

 
Чтобы не потерять эту дискуссию, сделайте закладку « предыдущая ветвь | форум | следующая ветвь »
Страницы: 1

mouse resizable Painbox (Pb) [Delphi, Win10]


RusSun ©   (24.11.21 18:51

Доброе время суток.
Хочу сделать сабж.
Пример брал отсюда:
https://disk.yandex.ru/d/RozofejyF2ZtRg
Не понимаю как правильно прикрутить к PB ?
Что вышло на данный момент времени:
https://disk.yandex.ru/d/Ue7ViiztZHLUxg
Процедуру формы по идее нужно " аттачить" (.AttachProc) к PB.
program PbTested;
uses
KOL,messages,windows;
//{$R *.res}
type
PForm1 = ^TForm1;
TForm1 = object(TObj)
  Form: PControl;
private
public
 procedure WMNChitTest(Sender: PControl;var Msg: TWMNChitTest); //message WM_NCHITTEST;
end;

var
Form1: PForm1;
PB:Pcontrol;
 f:boolean;
 mX,mY:integer;

procedure TForm1.WMNCHITTEST(Sender: PControl;var Msg: TWMNChitTest);
var p: TPoint;
begin
getcursorpos(p);
 Inherited;
   WITH Msg DO   Begin
 ScreenToClient(PB.Handle,p);
if (Result = HTCLIENT) and (PointInRect(p, MakeRect(0, 0, 10, 10))) then
   Result := HTTOPLEFT;
 if (Result = HTCLIENT) and (PointInRect(p,MakeRect(PB.Width-10,PB.Height-10,PB.Width,PB.Height ))) then
   Result := HTBOTTOMRIGHT;
 if (Result = HTCLIENT) and (PointInRect(p,MakeRect(PB.Width-10,0,PB.Width,10 ))) then
   Result := HTTOPRIGHT;
 if (Result = HTCLIENT) and (PointInRect(p,MakeRect(0,PB.Height-10,10,PB.Height ))) then
   Result := HTBOTTOMLEFT;
  end;
end;
procedure PBMouseDown(dummy:pointer;Sender: PControl; var Mouse: TMouseEventData);
begin
f:=true;
mx:=Mouse.X;
my:=Mouse.Y;
end;
procedure PBMouseMove(dummy:pointer;Sender: PControl; var Mouse: TMouseEventData);
begin
if f then {если можно двигать, то двигаем}
begin
 PB.Left:=PB.Left-(mX-Mouse.X);
 PB.Top:=PB.Top-(mY-Mouse.Y);
end;
end;
procedure PBMouseUp(dummy:pointer;Sender: PControl; var Mouse: TMouseEventData);
begin
f:=false
end;
//==Main Form==//
procedure NewForm1(var Result: PForm1; AParent: PControl);
begin
New(Result, Create);
with Result^ do
begin
  //Applet := NewApplet('');
  //if Fs.IsSaved then MsgOk(' IS Saved true ') else  MsgOk(' IS Saved False ');

  Form := NewForm(AParent, '').SetClientSize( 320, 240 ).CenterOnParent;
  Form.Add2AutoFree(Result);
  Form.StayOnTop:=true;
 // Btn:= NewButton(Form, ' make my copy active ' ).SetAlign ( caTop ).CenterOnParent;
   PB := NewPaintBox(form).SetPosition(10,10).setclientsize(300,220);
   PB.color:= TColor(clGray);
   PB.OnMouseDown:=TOnMouse(MakeMethod(nil, @PBMouseDown));
   PB.OnMouseMove:=TOnMouse(MakeMethod(nil, @PBMouseMove));
   PB.OnMouseUp  :=TOnMouse(MakeMethod(nil, @PBMouseUp));
  // PB.AttachProc(@WMNCHITTEST);
  // PB.OnMessage:= TOnMessage(MakeMethod(nil,@WMNCHITTEST));
  //Form.Color:= clActiveBorder;
  //Form.
  Applet := Form;
end;
end;

begin
NewForm1(Form1, nil);
Run(Form1.Form);
end.


dmk ©   (28.11.21 04:14[1]

Не очень понял - нужно изменение размеров панели или прилипание объектов к чему то?


RusSun ©   (28.11.21 07:16[2]

to dmk
нужно -> изменение размеров панели
Потом добавлю перемещение панели по нажатию на правую кнопку мыши на панели.


RusSun ©   (28.11.21 07:47[3]

Перемещение по нажатию правой кнопки мыши. Дополнил текущий код.
procedure PBMouseDown(dummy:pointer;Sender: PControl; var Mouse: TMouseEventData);
begin
if (Mouse.Button = mbRight)
then
begin
f:=true;
mx:=Mouse.X;
my:=Mouse.Y;
end;
end;


dmk ©   (28.11.21 18:05[4]

Писал я как раз изменение размеров контролов.
Вот пример как работает + исходник модуля:
https://disk.yandex.ru/d/K_iNB-Si5-ZA8w


dmk ©   (28.11.21 21:09[5]

Из-за некорректного присвоения объекты не прилипали к величине FGridSize.
Если заменить в исходнике эти процедуры - прилипание восстановится.


//---------------------------------------------------------------------------------

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
 DX, DY: Integer;
 Moving: Boolean;

begin
 if (Sender is TControl) then
 begin
   // Только передвижение
   if FControlCaptured then
   begin
     GetCursorPos(FNewPos);
     FNewPos.X := SnapTo(FNewPos.X, FGridSize);
     FNewPos.Y := SnapTo(FNewPos.Y, FGridSize);
     DX := (FNewPos.X - FOldPos.X);
     DY := (FNewPos.Y - FOldPos.Y);
     Moving := (DX <> 0) or (DY <> 0);

     if Moving then
     begin
       MoveControl(FControl, DX, DY);
       ShowProps(FControl);
       FOldPos := FNewPos;
       RepaintUnderControl(FControl);
       if IsPublishedProp(FControl, FTextVisible) then
       begin
         SetOrdProperty(FControl, FTextVisible, Integer(true));
       end;
     end;
   end;
 end;
end;

//-------------------------------------------------------------------------------------------------------

procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var
 C: TControl;

begin
 if (Sender is TControl) and (Button = mbLeft) then
 begin
   C := TControl(Sender);

   //------------------------
   // Если щелкнули по форме
   //------------------------

   if (C = Self) then
   begin
     FCorners.Hide;
     C.Cursor := crDefault;
     C.Repaint;

     DeselectControl(FControl);

     FControlSelected := False;
     FControlCaptured := False;
   end
   else
   //---------------------------
   // Если щелкнули по контролу
   //---------------------------
   begin
     if StringInList(C.ClassName, FPossibleControlsList) then
     begin
       // Сброс выделенного объекта
       DeselectControl(FControl);

       // Сброс флага захвата
       FControlCaptured := False;

       // Новый выделенный объект
       FControl := C;
       FControl.Cursor := crHandPoint;

       ShowProps(FControl);

       // Позиция мыши
       GetCursorPos(FOldPos);
       FOldPos.X := SnapTo(FOldPos.X, FGridSize);
       FOldPos.Y := SnapTo(FOldPos.Y, FGridSize);
       FNewPos := FOldPos;

       // Флаг захвата объекта
       FControlCaptured := True;

       // Рисуем рамку выделения объекта
       ShowControlFrame(FControl);
     end;
   end;
 end;
end;


dmk ©   (28.11.21 21:44[6]

Или можно просто скачать новые исходники демки:
https://disk.yandex.ru/d/AIPkaN7c_wITEQ


RusSun ©   (01.12.21 04:41[7]

Спасибо. Посмотрю позже. Первая ссылка[4] даёт сообщение :
"Ничего не найдено
Владелец удалил файлы либо закрыл к ним доступ или в ссылке опечатка."


ParanoiS ©   (10.12.21 04:13[8]

to RusSun: А почему просто не послать сообщение WM_SYSCOMMAND контролу после определения позиции курсора? С соответствующим флагом: SC_SIZE+n и ли SC_MOVE+2 ? Ща попробую набросать...


ParanoiS ©   (10.12.21 04:20[9]


procedure TForm1.Panel1MouseDown(Sender: PControl; var Mouse: TMouseEventData);
var
 P: TPoint;
begin
 ReleaseCapture;
 if Mouse.Button=mbLeft then begin
   GetCursorPos(P);
   P:=Sender.Screen2Client(P);

   if (P.X<12) and (P.Y<12) then // up/left
     Sender.Perform(WM_SYSCOMMAND,SC_SIZE+4,0) else
   if (P.X>Sender.Width-12) and (P.Y<12) then // up/right
     Sender.Perform(WM_SYSCOMMAND,SC_SIZE+5,0) else
   if (P.X<12) and (P.Y>Sender.Height-12) then // down/left
     Sender.Perform(WM_SYSCOMMAND,SC_SIZE+8,0) else
   if (P.X>Sender.Width-12) and (P.Y>Sender.Height-12) then // down/right
     Sender.Perform(WM_SYSCOMMAND,SC_SIZE+?,0) else

   if (P.X<12) then // left
     Sender.Perform(WM_SYSCOMMAND,SC_SIZE+1,0) else
   if (P.X>Sender.Width-12) then // right
     Sender.Perform(WM_SYSCOMMAND,SC_SIZE+2,0) else
   if (P.Y<12) then // up
     Sender.Perform(WM_SYSCOMMAND,SC_SIZE+3,0) else
   if (P.Y>Sender.Height-12) then // down
     Sender.Perform(WM_SYSCOMMAND,SC_SIZE+6,0) else

     Sender.Perform(WM_SYSCOMMAND,SC_MOVE+2,0);
 end;
end;


ParanoiS ©   (10.12.21 04:23[10]

По мне так проще - в одном методе и размеры и перемещение. Только вот для нижнего правого угла не подобрал, но ты разберёшься :)


RusSun ©   (12.12.21 15:20[11]

Привет! to>ParanoiS
Спасибо.
[10] :);)


RusSun ©   (13.12.21 09:51[12]

if (P.X>Sender.Width-12) and (P.Y>Sender.Height-12) then // down/right
    Sender.Perform(WM_SYSCOMMAND,$F008,0) else
if (P.X<12) and (P.Y>Sender.Height-12) then // down/left
    Sender.Perform(WM_SYSCOMMAND,$F007,0) else


:)


RusSun ©   (13.12.21 10:03[13]

Большущее Спасибо=) to dmk очень интересный код.


ParanoiS ©   (08.01.22 19:48[14]

Я тут понял что ребята ваш код мне офигенно помог. только под аэро:) спасибо:)


Страницы: 1 версия для печати

Написать ответ

Ваше имя (регистрация  E-mail 







Разрешается использование тегов форматирования текста:
<b>жирный</b> <i>наклонный</i> <u>подчеркнутый</u>,
а для выделения текста программ, используйте <code> ... </code>
и не забывайте закрывать теги! </b></i></u></code> :)


Наверх

  Рейтинг@Mail.ru     Титульная страница Поиск, карта сайта Написать письмо