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]
Я тут понял что ребята ваш код мне офигенно помог. только под аэро:) спасибо:)
Разрешается использование тегов форматирования текста:
<b>жирный</b> <i>наклонный</i>
<u>подчеркнутый</u>,
а для выделения текста программ, используйте <code> ... </code>
и не забывайте закрывать теги! </b></i></u></code> :)
Наверх 
Чтобы не потерять эту дискуссию, сделайте закладку