Текущий архив: 2017.01.15;
Скачать: CL | DM;

Вниз

Отрисовка контрола при перемещении   Найти похожие ветки 

← →
dmk ©   (2015-04-21 14:28) [0]

Всем привет! Как рисовать на компоненте не делая свою надстройку с перекрытием Paint? Пробовал просто поверх рисовать, но компоненты ведут себя по разному при нажатии или перемещении. Иногда рамка рисуется поверх, а иногда исчезает. Происходит как то хаотично. Нужно, чтобы рамка была видна при нажатии кнопки и перемещении и исчезала, когда отпустишь.

Процедуры событий мыши у всех компонентов одинаковые.
Win64, Delphi XE6

unit test2;

interface

uses
 Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
 Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls;

type
 TForm1 = class(TForm)
   Button1: TButton;
   Button2: TButton;
   Edit1: TEdit;
   Panel1: TPanel;
   procedure Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   procedure Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
   procedure Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
 protected
   FCaptured: boolean;
   FCapturedHandle: HWND;
   FWinControl: TWinControl;
   FOldPos: TPoint;
   FNewPos: TPoint;

   procedure DrawWindowFrame(wnd: HWND);
   procedure MoveControl(AControl: TControl; dx, dy: integer);
 private
   { Private declarations }

 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.DrawWindowFrame(wnd: HWND);
var
 c: TCanvas;
 R, DR: TRect;

begin
 GetWindowRect(wnd, R);

 DR.Left := 0;
 DR.Top := 0;
 DR.Width := R.Right - R.Left;
 DR.Height := R.Bottom - R.Top;

 c := TCanvas.Create;
 with c do
 begin
   Handle := GetWindowDC(wnd);
   Brush.Style := bsClear;
   Pen.Color := clRed;
   Pen.Style := psDot;
   Pen.Width := 1;
   Rectangle(DR);
   ReleaseDC(wnd, Handle);
   Handle := 0;
   Free;
 end;
end;

procedure TForm1.MoveControl(AControl: TControl; dx, dy: integer);
begin
 AControl.Left := AControl.Left + dx;
 AControl.Top := AControl.Top + dy;
end;

procedure TForm1.Button1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 if Sender = Self then exit;
 if (Sender is TWinControl) and (Button = mbLeft) then
 begin
   FWinControl := TWinControl(Sender);
   FCaptured := true;
   FCapturedHandle := SetCapture(FWinControl.Handle);
   GetCursorPos(FOldPos);
   FWinControl.Repaint;
   DrawWindowFrame(FCapturedHandle);
   caption := FWinControl.Name;
 end;
end;

procedure TForm1.Button1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
 xc, yc: integer;
 moving: boolean;

begin
 if (Sender is TWinControl) then
 begin
   if FCaptured then
   begin
     GetCursorPos(FNewPos);
     xc := FNewPos.X - FOldPos.X;
     yc := FNewPos.Y - FOldPos.Y;
     moving := (xc <> 0) or (yc <> 0);
     if moving then
     begin
       MoveControl(FWinControl, xc, yc);
       DrawWindowFrame(FCapturedHandle);
       FOldPos := FNewPos;
     end;
   end;
 end;
end;

procedure TForm1.Button1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
 if (Sender is TWinControl) and (Button = mbLeft) then
 begin
   if FCaptured then
   begin
     FWinControl := TWinControl(Sender);
     if ReleaseCapture then FCaptured := false;
     FWinControl.Repaint;
   end;
 end;
end;

end.


---

← →
DVM ©   (2015-04-21 16:05) [1]

имхо, рамку надо рисовать не на самом контроле, который перемещают (а-ля редактор форм в делфи), а на том окне, по которому его перемещают.

---

← →
dmk ©   (2015-04-21 16:27) [2]

ой, моргает все. сплошной flickering ;D

---

← →
kilkennycat ©   (2015-04-21 17:05) [3]

а если в wm_paint контрола?

---

← →
Rouse_ ©   (2015-04-21 17:30) [4]

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

---

← →
dmk ©   (2015-04-21 20:14) [5]

Не нашел ничего лучше, чем сделать наследников от нужных компонентов.

---

Страницы: 1 вся ветка

Текущий архив: 2017.01.15;
Скачать: CL | DM;

Наверх

Память: 0.48 MB
Время: 0.019 c