Форум: "Начинающим";
Текущий архив: 2017.09.10;
Скачать: [xml.tar.bz2];

Вниз

TEdit не хочет перерисовываться   Найти похожие ветки 

← →
dmk ©   (2015-09-25 05:23) [0]

Привет!
Проблема в нежелании наследника TEdit принудительно перерисовываться.
В OnMouseUp FWinControl.Repaint не работает. Пробовал через WinApi, но тоже не перерисовывается. Даже если не наследовать, а брать чистый TEdit - тоже не хочет.
Delphi Prof XE6.

unit test2;

interface

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

type
 [ComponentPlatformsAttribute (pidWin32 or pidWin64)]
 TDmEdit = class(TEdit)
 protected
   FFrameColor: TColor;
   FFrameVisible: boolean;
   procedure WMPaint(var m: TWMPaint); message WM_PAINT;
 published
   property FrameColor: TColor read FFrameColor write FFrameColor;
   property FrameVisible: boolean read FFrameVisible write FFrameVisible;
 end;

type
 TForm1 = class(TForm)
   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);
   procedure FormShow(Sender: TObject);
 protected
   FCaptured: boolean;
   FCapturedHandle: HWND;
   FWinControl: TWinControl;
   FOldPos: TPoint;
   FNewPos: TPoint;
   procedure MoveControl(AControl: TControl; dx, dy: integer);
 private
   { Private declarations }
   Edit1: TDmEdit;
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

procedure DrawWindowFrame(wnd: HWND; AColor: TColor);
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 := AColor;
   Pen.Style := psDot;
   Pen.Width := 1;
   Rectangle(DR);
   ReleaseDC(wnd, Handle);
   Handle := 0;
   Free;
 end;
end;

procedure TDmEdit.WMPaint(var m: TWMPaint);
begin
 inherited;
 if FFrameVisible then
 begin
   DrawWindowFrame(Handle, FFrameColor);
   m.Result := NativeUInt(True);
 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;
   GetCursorPos(FOldPos);
   Screen.Cursor := crHandPoint;

   if (FWinControl is TDmEdit) then
   begin
     TDmEdit(FWinControl).FrameColor := clHighLight;
     TDmEdit(FWinControl).FrameVisible := true;
   end;

   FWinControl.Repaint;
 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
       if (FWinControl is TDmEdit) then
       begin
         TDmEdit(FWinControl).FrameVisible := true;
       end;
       MoveControl(FWinControl, xc, yc);
       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);
     FCaptured := false;
     if (FWinControl is TDmEdit) then
     begin
       TDmEdit(FWinControl).FrameVisible := false;
     end;
     //Проблема здесь!!!!
     FWinControl.Repaint; //<- Проблема: не перерисовывает!!!
     Screen.Cursor := crDefault;
   end;
 end;
end;

procedure TForm1.FormShow(Sender: TObject);
begin
 Edit1 := TDmEdit.Create(nil);
 Edit1.Parent := Self;
 Edit1.Left := 20;
 Edit1.Top := 20;
 Edit1.Width := 130;
 Edit1.Height := 25;
 Edit1.Name := "Edit7";
 Edit1.OnMouseDown := Self.OnMouseDown;
 Edit1.OnMouseUp := Self.OnMouseUp;
 Edit1.OnMouseMove := Self.OnMouseMove;
 Edit1.Show;
end;

end.

---

← →
dmk ©   (2015-09-25 05:24) [1]

Там рамка стираться должна, но она не стирается. Чего то я затупил :(

---

← →
dmk ©   (2015-09-25 16:51) [2]

Может что-то внутри VCL мешает перерисовке?

---

← →
dmk ©   (2015-09-26 01:34) [3]

Проблемы только с контролами состоящими из двух окон: TMemo и TEdit.
Так все хорошо:

procedure TDmEdit.WMPaint(var m: TWMPaint);
begin
 if FFrameVisible then
 begin
   inherited;
   DrawWindowFrame(Handle, FFrameColor);
   m.Result := NativeUInt(True);
 end
 else
 begin
   SendMessage(Handle, WM_NCPAINT, 0, 0);
   inherited;
 end;
end;


Спасибо! Вопрос снят.

---

← →
Rouse_ ©   (2015-09-26 02:47) [4]

Рамка это NC, отключи ее и будет тебе счастье

---

← →
имя   (2015-10-20 20:47) [5]

Удалено модератором

---

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

Форум: "Начинающим";
Текущий архив: 2017.09.10;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.46 MB
Время: 0.001 c