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

Вниз

Субклассинг контрола   Найти похожие ветки 

← →
LightGreen   (2010-02-06 15:12) [0]

Всем привет!
Мне нужно динамически отсубклассить контрол на форме. Я подменяю у него WndProc и делаю там отрисовку. Проблема в том, что в VCL есть код, который напрямую берёт родительский DC и начинает там что-то рисовать. Поэтому изображение заметно дёргается, так будто моя отрисовка идёт поверх стандартной. Есть ли возможность это как-то заблокировать? Хотелось бы обойтись без взлома vtable, но рассмотрю любые варианты :)

---

← →
DVM ©   (2010-02-06 15:44) [1]

> Проблема в том, что в VCL есть код, который напрямую берёт
> родительский DC и начинает там что-то рисовать.

Он что сам по себе берет что ли или как следствие обработки сообщений кодом vcl ?

---

← →
DVM ©   (2010-02-06 15:45) [2]

а вообще показывай как делаешь и где дергается

---

← →
LightGreen   (2010-02-07 01:44) [3]

Ну вот, набросал код, как я это делаю (см. ниже). В этом отрывке оно даже не дёргается, а просто рисует свой чекбокс поверх моей надписи, хотя я зову EndPaint, после которого, вроде бы никакой отрисовки быть не может!


unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls;

type
 TCheckBoxModifier = class
   FCheckBox: TCheckBox;
   FOldWndProc: TWndMethod;
   procedure WndProc(var Message: TMessage);
   procedure Paint;
 public
   constructor Create(C: TCheckBox);
   destructor Destroy; override;
 end;

 TForm1 = class(TForm)
   CheckBox1: TCheckBox;
   procedure FormCreate(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
 private
   FCheckBoxModifier: TCheckBoxModifier;
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

{ TCheckBoxModifier }

constructor TCheckBoxModifier.Create(C: TCheckBox);
begin
 FCheckBox := C;
 FOldWndProc := C.WindowProc;
 C.WindowProc := WndProc;
end;

destructor TCheckBoxModifier.Destroy;
begin
 FCheckBox.WindowProc := FOldWndProc;
 inherited;
end;

procedure TCheckBoxModifier.Paint;
var
 PS: PAINTSTRUCT;
 R: TRect;
begin
 BeginPaint(FCheckBox.Handle, PS);
 if not IsRectEmpty(PS.rcPaint) then
 begin
   R := FCheckBox.ClientRect;
   if FCheckBox.Checked then
     FillRect(PS.hdc, R, GetStockObject(WHITE_BRUSH))
   else
     FillRect(PS.hdc, R, GetStockObject(LTGRAY_BRUSH));
   SetBkMode(PS.hdc, TRANSPARENT);
   DrawText(PS.hdc, PAnsiChar(FCheckBox.Caption), Length(FCheckBox.Caption),
     R, DT_CENTER or DT_VCENTER);
 end;
 EndPaint(FCheckBox.Handle, PS);
end;

procedure TCheckBoxModifier.WndProc(var Message: TMessage);
begin
 case Message.Msg of
   WM_ERASEBKGND:
     Message.Result := 1; // suppress erase bkgnd
   WM_PAINT:
     Paint; // do custom paint
 else
   FOldWndProc(Message);
 end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 FCheckBoxModifier := TCheckBoxModifier.Create(CheckBox1);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
 FCheckBoxModifier.Free;
end;

end.


---

← →
Игорь Шевченко ©   (2010-02-07 02:02) [4]

при кликах Paint не вызывается, что легко проверить отладчиком.

---

← →
Игорь Шевченко ©   (2010-02-07 02:35) [5]

Вот более наглядный пример, показывающий, что при кликах на CheckBox WM_PAINT не генерируется:

unit main;

interface
uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls;

type
 TForm1 = class(TForm)
   CheckBox1: TCheckBox;
   Memo1: TMemo;
   Button1: TButton;
   procedure FormCreate(Sender: TObject);
   procedure Button1Click(Sender: TObject);
   procedure CheckBox1Click(Sender: TObject);
 private
   Log: TstringList;
   OldCbProc: Pointer;
   procedure NewCbProc (var Message: TMessage);
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.Button1Click(Sender: TObject);
begin
 Memo1.Lines.Assign(Log);
end;

procedure TForm1.CheckBox1Click(Sender: TObject);
begin
 Log.Add("Click");
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 Log := TStringList.Create;
 OldCbProc := Pointer(GetWindowLong(CheckBox1.Handle, GWL_WNDPROC));
 SetWindowLong(CheckBox1.Handle, GWL_WNDPROC, DWORD(MakeObjectInstance(NewCbProc)));
end;

procedure TForm1.NewCbProc(var Message: TMessage);
begin
 case Message.Msg of
 WM_PAINT:
   Log.Add("Paint");
 end;
 Message.Result := CallWindowProc(OldCbProc, CheckBox1.Handle,
   Message.Msg, Message.WParam, Message.LParam);
end;

end.

И, соответственно, протокол:

Paint
Click
Click
Click
Click
Click
Click
Click
Click
Click
Click
Click
Click
Click
Click
Click
Click
Click
Paint

---

← →
DVM ©   (2010-02-07 14:03) [6]

> LightGreen

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

---

← →
LightGreen   (2010-02-07 14:24) [7]

Выходит, что это код comctl32 рисует напрямую на DC, а не код VCL... Теперь ясно, откуда появлялось "дёргание". И примерно понятно, как с этим бороться.
Спасибо!

---

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

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

Наверх

Память: 0.49 MB
Время: 0.009 c