| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Перехват события у TMyFrame [D7, XP]

Ega23 ©   (2007-04-28 14:28:00) 

Есть некий TMyFrame с какой-то начинкой. Надо в рамках этого фрейма уметь перехватывать WM_ERASEBKGND.
Таких фреймов может быть много.

Вопрос: как лучше это сделать? Application-то один...

---

Игорь Шевченко   (2007-04-28 15:42:00) [1]

unit MyFrame;

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

type
 TfFoo = class(TFrame)
   Label1: TLabel;
 private
   FBitmap: TBitmap;
   procedure WMEraseBkgnd (var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
 public
   constructor Create (AOwner: TComponent); override;
   destructor Destroy; override;
 end;

implementation

{$R *.dfm}

{ TFrame1 }

function CreateBrushBitmap (Dark, Middle, Light: COLORREF): TBitmap;
begin
 Result := TBitmap.Create;
 with Result do begin
   Width := 8;
   Height := 8;
   with Canvas do begin
     Brush.Color := Middle;
     FillRect(Rect(0, 0, Width, Height));
     Pixels[0,0] := Light;
     Pixels[4,0] := Light;
     Pixels[0,4] := Light;
     Pixels[4,4] := Light;
     Pixels[1,1] := Dark;
     Pixels[5,1] := Dark;
     Pixels[1,5] := Dark;
     Pixels[5,5] := Dark;
    end;
 end;
end;

constructor TfFoo.Create(AOwner: TComponent);
begin
 FBitmap := CreateBrushBitmap (RGB($00,$3C,$5A), RGB($08,$5D,$8B),
   RGB($08,$8D,$CD));
 inherited;
end;

destructor TfFoo.Destroy;
begin
 FBitmap.Free;
 inherited;
end;

procedure TfFoo.WMEraseBkgnd(var Message: TWMEraseBkgnd);
var
 Canvas: TCanvas;
begin
 Canvas := TCanvas.Create;
 try
   Canvas.Handle := Message.DC;
   Canvas.Brush.Bitmap := FBitmap;
   Canvas.FillRect(ClientRect);
   Canvas.Handle := 0;
 finally
   Canvas.Free;
 end;
end;

end.

object fFoo: TfFoo
 Left = 0
 Top = 0
 Width = 298
 Height = 76
 TabOrder = 0
 TabStop = True
 object Label1: TLabel
   Left = 56
   Top = 24
   Width = 189
   Height = 21
   Alignment = taCenter
   AutoSize = False
   Caption = 'This is my frame'
   Font.Charset = DEFAULT_CHARSET
   Font.Color = clWindow
   Font.Height = -16
   Font.Name = 'Tahoma'
   Font.Style = [fsBold]
   ParentFont = False
   Transparent = True
 end
end

unit main;

interface

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

type
 TForm1 = class(TForm)
   fFoo1: TfFoo;
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

end.

---

Ega23   (2007-04-28 15:32:00) [2]

> перекроет


спасибо!

---

Игорь Шевченко   (2007-04-28 15:31:00) [3]

> Новая реализация перекроет существующую или нет?


перекроет

---

Ega23   (2007-04-28 15:27:00) [4]

Так-то оно так. А если где-то в недрах WinControl уже есть реакция на этот message? Причём в private-секции?
Новая реализация перекроет существующую или нет?

---

Игорь Шевченко   (2007-04-28 15:17:00) [5]

type
 TfFoo = class(TseBaseFrame)
 ...
   procedure UmSetFooFrameFocus (
     var Message: TMessage); message UM_SETFOOFRAMEFOCUS;
 end;

например так

---

Наверх