Несколько методов, обрабатывающих одно сообщение

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

unit ManyForm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TFormManyMess = class(TForm)

LBox: TListBox;

Label1: TLabel;

Button1: TButton;

procedure FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ Private declarations }

public

procedure WndProc(var Message: TMessage); override;

procedure DefaultHandler(var Message); override;

procedure WmLButtonDown (var Message: TWMMouse);

message wm_lButtonDown;

procedure MouseDown(Button: TMouseButton;

Shift: TShiftState; X, Y: Integer); override;

procedure ApplicationMessage (var Msg: TMsg;

var Handled: Boolean);

end;

var

FormManyMess: TFormManyMess;

implementation

{$R *.DFM}

procedure TFormManyMess.FormMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState;

X, Y: Integer);

begin

if Button = mbLeft then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘FormMouseDown’, X, Y]));

end;

procedure TFormManyMess.WndProc(var Message: TMessage);

begin

if Message.Msg = wm_LButtonDown then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘WndProc’, LoWord (Message.LParam),

HiWord (Message.LParam)]));

inherited;

end;

procedure TFormManyMess.DefaultHandler(var Message);

begin

with TMessage (Message) do

if Msg = wm_LButtonDown then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘DefaultHandler’, LoWord (LParam),

HiWord (LParam)]));

inherited;

end;

procedure TFormManyMess.WmLButtonDown (var Message: TWMMouse);

begin

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘WmLButtonDown’, Message.XPos, Message.YPos]));

inherited;

end;

procedure TFormManyMess.MouseDown(Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if Button = mbLeft then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘MouseDown’, X, Y]));

inherited;

end;

procedure TFormManyMess.ApplicationMessage (var Msg: TMsg;

var Handled: Boolean);

begin

if (Msg.Message = wm_LButtonDown) and

(Msg.hWnd = Handle) then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘ApplicationMessage’, LoWord (Msg.LParam),

HiWord (Msg.LParam)]));

Handled := False;

end;

procedure TFormManyMess.FormCreate(Sender: TObject);

begin

Application.OnMessage := ApplicationMessage;

end;

procedure TFormManyMess.Button1Click(Sender: TObject);

begin

LBox.Clear;

end;

end.

Загрузить исходный код проекта

{/codecitation}

Мониторинг сообщений

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Жуткокристалический монитор.

unit Mlist;

interface

uses

SysUtils, Classes, Messages, Controls;

var

MsgList: TStringList;

function GetMessageName (Msg: Integer): string;

implementation

function GetMessageName (Msg: Integer): string;

var

N: Integer;

begin

N := MsgList.IndexOfObject (TObject(Msg));

if N >= 0 then

Result := MsgList.Strings [N]

else if (Msg >= wm_User) and

(Msg <= $7FFF) then

Result := Format (

‘wm_User message (%d)’, [Msg])

else

Result := Format (

‘Undocumented (%d)’, [Msg]);

end;

initialization

MsgList := TStringList.Create;

MsgList.AddObject (‘wm_Null’, TObject($0000));

MsgList.AddObject (‘wm_Create’, TObject($0001));

MsgList.AddObject (‘wm_Destroy’, TObject($0002));

MsgList.AddObject (‘wm_Move’, TObject($0003));

MsgList.AddObject (‘wm_Size’, TObject($0005));

MsgList.AddObject (‘wm_Activate’, TObject($0006));

MsgList.AddObject (‘wm_SetFocus’, TObject($0007));

MsgList.AddObject (‘wm_KillFocus’, TObject($0008));

MsgList.AddObject (‘wm_Enable’, TObject($000A));

MsgList.AddObject (‘wm_SetRedraw’, TObject($000B));

MsgList.AddObject (‘wm_SetText’, TObject($000C));

MsgList.AddObject (‘wm_GetText’, TObject($000D));

MsgList.AddObject (‘wm_GetTextLength’, TObject($000E));

MsgList.AddObject (‘wm_Paint’, TObject($000F));

MsgList.AddObject (‘wm_Close’, TObject($0010));

MsgList.AddObject (‘wm_QueryEndSession’, TObject($0011));

MsgList.AddObject (‘wm_Quit’, TObject($0012));

MsgList.AddObject (‘wm_QueryOpen’, TObject($0013));

MsgList.AddObject (‘wm_EraseBkGnd’, TObject($0014));

MsgList.AddObject (‘wm_SysColorChange’, TObject($0015));

MsgList.AddObject (‘wm_EndSession’, TObject($0016));

MsgList.AddObject (‘wm_SystemError’, TObject($0017));

MsgList.AddObject (‘wm_ShowWindow’, TObject($0018));

MsgList.AddObject (‘wm_CtlColor’, TObject($0019));

MsgList.AddObject (‘wm_WinIniChange’, TObject($001A));

MsgList.AddObject (‘wm_DevModeChange’, TObject($001B));

MsgList.AddObject (‘wm_ActivateApp’, TObject($001C));

MsgList.AddObject (‘wm_FontChange’, TObject($001D));

MsgList.AddObject (‘wm_TimeChange’, TObject($001E));

MsgList.AddObject (‘wm_CancelMode’, TObject($001F));

MsgList.AddObject (‘wm_SetCursor’, TObject($0020));

MsgList.AddObject (‘wm_MouseActivate’, TObject($0021));

MsgList.AddObject (‘wm_ChildActivate’, TObject($0022));

MsgList.AddObject (‘wm_QueueSync’, TObject($0023));

MsgList.AddObject (‘wm_GetMinMaxInfo’, TObject($0024));

MsgList.AddObject (‘wm_PaintIcon’, TObject($0026));

MsgList.AddObject (‘wm_IconEraseBkGnd’, TObject($0027));

MsgList.AddObject (‘wm_NextDlgCtl’, TObject($0028));

MsgList.AddObject (‘wm_SpoolerStatus’, TObject($002A));

MsgList.AddObject (‘wm_DrawItem’, TObject($002B));

MsgList.AddObject (‘wm_MeasureItem’, TObject($002C));

MsgList.AddObject (‘wm_DeleteItem’, TObject($002D));

MsgList.AddObject (‘wm_VKeyToItem’, TObject($002E));

MsgList.AddObject (‘wm_CharToItem’, TObject($002F));

MsgList.AddObject (‘wm_SetFont’, TObject($0030));

MsgList.AddObject (‘wm_GetFont’, TObject($0031));

MsgList.AddObject (‘wm_QueryDragIcon’, TObject($0037));

MsgList.AddObject (‘wm_CompareItem’, TObject($0039));

MsgList.AddObject (‘wm_Compacting’, TObject($0041));

MsgList.AddObject (‘wm_CommNotify’, TObject($0044));

MsgList.AddObject (‘wm_WindowPosChanging’, TObject($0046));

MsgList.AddObject (‘wm_WindowPosChanged’, TObject($0047));

MsgList.AddObject (‘wm_Power’, TObject($0048));

MsgList.AddObject (‘wm_CopyData’, TObject($004A));

MsgList.AddObject (‘wm_CancelJournal’, TObject($004B));

MsgList.AddObject (‘wm_Notify’, TObject($004E));

MsgList.AddObject (‘wm_StyleChanging’, TObject($007C));

MsgList.AddObject (‘wm_StyleChanged’, TObject($007D));

MsgList.AddObject (‘wm_GetIcon’, TObject($007F));

MsgList.AddObject (‘wm_SetIcon’, TObject($0080));

MsgList.AddObject (‘wm_NCCreate’, TObject($0081));

MsgList.AddObject (‘wm_NCDestroy’, TObject($0082));

MsgList.AddObject (‘wm_NCCalcSize’, TObject($0083));

MsgList.AddObject (‘wm_NCHitTest’, TObject($0084));

MsgList.AddObject (‘wm_NCPaint’, TObject($0085));

MsgList.AddObject (‘wm_NCActivate’, TObject($0086));

MsgList.AddObject (‘wm_GetDlgCode’, TObject($0087));

MsgList.AddObject (‘wm_NCMouseMove’, TObject($00A0));

MsgList.AddObject (‘wm_NCLButtonDown’, TObject($00A1));

MsgList.AddObject (‘wm_NCLButtonUp’, TObject($00A2));

MsgList.AddObject (‘wm_NCLButtonDblClk’, TObject($00A3));

MsgList.AddObject (‘wm_NCRButtonDown’, TObject($00A4));

MsgList.AddObject (‘wm_NCRButtonUp’, TObject($00A5));

MsgList.AddObject (‘wm_NCRButtonDblClk’, TObject($00A6));

MsgList.AddObject (‘wm_NCMButtonDown’, TObject($00A7));

MsgList.AddObject (‘wm_NCMButtonUp’, TObject($00A8));

MsgList.AddObject (‘wm_NCMButtonDblClk’, TObject($00A9));

MsgList.AddObject (‘wm_KeyDown’, TObject($0100));

MsgList.AddObject (‘wm_KeyUp’, TObject($0101));

MsgList.AddObject (‘wm_Char’, TObject($0102));

MsgList.AddObject (‘wm_DeadChar’, TObject($0103));

MsgList.AddObject (‘wm_SysKeyDown’, TObject($0104));

MsgList.AddObject (‘wm_SysKeyUp’, TObject($0105));

MsgList.AddObject (‘wm_SysChar’, TObject($0106));

MsgList.AddObject (‘wm_SysDeadChar’, TObject($0107));

MsgList.AddObject (‘wm_InitDialog’, TObject($0110));

MsgList.AddObject (‘wm_Command’, TObject($0111));

MsgList.AddObject (‘wm_SysCommand’, TObject($0112));

MsgList.AddObject (‘wm_Timer’, TObject($0113));

MsgList.AddObject (‘wm_HScroll’, TObject($0114));

MsgList.AddObject (‘wm_VScroll’, TObject($0115));

MsgList.AddObject (‘wm_InitMenu’, TObject($0116));

MsgList.AddObject (‘wm_InitMenuPopup’, TObject($0117));

MsgList.AddObject (‘wm_MenuSelect’, TObject($011F));

MsgList.AddObject (‘wm_MenuChar’, TObject($0120));

MsgList.AddObject (‘wm_EnterIdle’, TObject($0121));

MsgList.AddObject (‘wm_CtlColorMsgbox’, TObject($0132));

MsgList.AddObject (‘wm_CtlColorEdit’, TObject($0133));

MsgList.AddObject (‘wm_CtlColorListbox’, TObject($0134));

MsgList.AddObject (‘wm_CtlColorBtn’, TObject($0135));

MsgList.AddObject (‘wm_CtlColorDlg’, TObject($0136));

MsgList.AddObject (‘wm_CtlColorScrollbar’, TObject($0137));

MsgList.AddObject (‘wm_CtlColorStatic’, TObject($0138));

MsgList.AddObject (‘wm_MouseMove’, TObject($0200));

MsgList.AddObject (‘wm_LButtonDown’, TObject($0201));

MsgList.AddObject (‘wm_LButtonUp’, TObject($0202));

MsgList.AddObject (‘wm_LButtonDblClk’, TObject($0203));

MsgList.AddObject (‘wm_RButtonDown’, TObject($0204));

MsgList.AddObject (‘wm_RButtonUp’, TObject($0205));

MsgList.AddObject (‘wm_RButtonDblClk’, TObject($0206));

MsgList.AddObject (‘wm_MButtonDown’, TObject($0207));

MsgList.AddObject (‘wm_MButtonUp’, TObject($0208));

MsgList.AddObject (‘wm_MButtonDblClk’, TObject($0209));

MsgList.AddObject (‘wm_ParentNotify’, TObject($0210));

MsgList.AddObject (‘wm_MDICreate’, TObject($0220));

MsgList.AddObject (‘wm_MDIDestroy’, TObject($0221));

MsgList.AddObject (‘wm_MDIActivate’, TObject($0222));

MsgList.AddObject (‘wm_MDIRestore’, TObject($0223));

MsgList.AddObject (‘wm_MDINext’, TObject($0224));

MsgList.AddObject (‘wm_MDIMaximize’, TObject($0225));

MsgList.AddObject (‘wm_MDITile’, TObject($0226));

MsgList.AddObject (‘wm_MDICascade’, TObject($0227));

MsgList.AddObject (‘wm_MDIIconArrange’, TObject($0228));

MsgList.AddObject (‘wm_MDIGetActive’, TObject($0229));

MsgList.AddObject (‘wm_MDISetMenu’, TObject($0230));

MsgList.AddObject (‘wm_DropFiles’, TObject($0233));

MsgList.AddObject (‘wm_MDIRefreshMenu’, TObject($0234));

MsgList.AddObject (‘wm_Cut’, TObject($0300));

MsgList.AddObject (‘wm_Copy’, TObject($0301));

MsgList.AddObject (‘wm_Paste’, TObject($0302));

MsgList.AddObject (‘wm_Clear’, TObject($0303));

MsgList.AddObject (‘wm_Undo’, TObject($0304));

MsgList.AddObject (‘wm_RenderFormat’, TObject($0305));

MsgList.AddObject (‘wm_RenderAllFormats’, TObject($0306));

MsgList.AddObject (‘wm_DestroyClipboard’, TObject($0307));

MsgList.AddObject (‘wm_DrawClipboard’, TObject($0308));

MsgList.AddObject (‘wm_PaintClipboard’, TObject($0309));

MsgList.AddObject (‘wm_VScrollClipboard’, TObject($030A));

MsgList.AddObject (‘wm_SizeClipboard’, TObject($030B));

MsgList.AddObject (‘wm_AskCBFormatName’, TObject($030C));

MsgList.AddObject (‘wm_ChangeCBChain’, TObject($030D));

MsgList.AddObject (‘wm_HScrollClipboard’, TObject($030E));

MsgList.AddObject (‘wm_QueryNewPalette’, TObject($030F));

MsgList.AddObject (‘wm_PaletteIsChanging’, TObject($0310));

MsgList.AddObject (‘wm_PaletteChanged’, TObject($0311));

// Delphi notifications and messages

MsgList.AddObject (‘CM_ACTIVATE’, TObject(CM_BASE 0));

MsgList.AddObject (‘CM_DEACTIVATE’, TObject(CM_BASE 1));

MsgList.AddObject (‘CM_GOTFOCUS’, TObject(CM_BASE 2));

MsgList.AddObject (‘CM_LOSTFOCUS’, TObject(CM_BASE 3));

MsgList.AddObject (‘CM_CANCELMODE’, TObject(CM_BASE 4));

MsgList.AddObject (‘CM_DIALOGKEY’, TObject(CM_BASE 5));

MsgList.AddObject (‘CM_DIALOGCHAR’, TObject(CM_BASE 6));

MsgList.AddObject (‘CM_FOCUSCHANGED’, TObject(CM_BASE 7));

MsgList.AddObject (‘CM_PARENTFONTCHANGED’, TObject(CM_BASE 8));

MsgList.AddObject (‘CM_PARENTCOLORCHANGED’, TObject(CM_BASE 9));

MsgList.AddObject (‘CM_HITTEST’, TObject(CM_BASE 10));

MsgList.AddObject (‘CM_VISIBLECHANGED’, TObject(CM_BASE 11));

MsgList.AddObject (‘CM_ENABLEDCHANGED’, TObject(CM_BASE 12));

MsgList.AddObject (‘CM_COLORCHANGED’, TObject(CM_BASE 13));

MsgList.AddObject (‘CM_FONTCHANGED’, TObject(CM_BASE 14));

MsgList.AddObject (‘CM_CURSORCHANGED’, TObject(CM_BASE 15));

MsgList.AddObject (‘CM_CTL3DCHANGED’, TObject(CM_BASE 16));

MsgList.AddObject (‘CM_PARENTCTL3DCHANGED’, TObject(CM_BASE 17));

MsgList.AddObject (‘CM_TEXTCHANGED’, TObject(CM_BASE 18));

MsgList.AddObject (‘CM_MOUSEENTER’, TObject(CM_BASE 19));

MsgList.AddObject (‘CM_MOUSELEAVE’, TObject(CM_BASE 20));

MsgList.AddObject (‘CM_MENUCHANGED’, TObject(CM_BASE 21));

MsgList.AddObject (‘CM_APPKEYDOWN’, TObject(CM_BASE 22));

MsgList.AddObject (‘CM_APPSYSCOMMAND’, TObject(CM_BASE 23));

MsgList.AddObject (‘CM_BUTTONPRESSED’, TObject(CM_BASE 24));

MsgList.AddObject (‘CM_SHOWINGCHANGED’, TObject(CM_BASE 25));

MsgList.AddObject (‘CM_ENTER’, TObject(CM_BASE 26));

MsgList.AddObject (‘CM_EXIT’, TObject(CM_BASE 27));

MsgList.AddObject (‘CM_DESIGNHITTEST’, TObject(CM_BASE 28));

MsgList.AddObject (‘CM_ICONCHANGED’, TObject(CM_BASE 29));

MsgList.AddObject (‘CM_WANTSPECIALKEY’, TObject(CM_BASE 30));

MsgList.AddObject (‘CM_INVOKEHELP’, TObject(CM_BASE 31));

MsgList.AddObject (‘CM_WINDOWHOOK’, TObject(CM_BASE 32));

MsgList.AddObject (‘CM_RELEASE’, TObject(CM_BASE 33));

MsgList.AddObject (‘CM_SHOWHINTCHANGED’, TObject(CM_BASE 34));

MsgList.AddObject (‘CM_PARENTSHOWHINTCHANGED’, TObject(CM_BASE 35));

MsgList.AddObject (‘CM_SYSCOLORCHANGE’, TObject(CM_BASE 36));

MsgList.AddObject (‘CM_WININICHANGE’, TObject(CM_BASE 37));

MsgList.AddObject (‘CM_FONTCHANGE’, TObject(CM_BASE 38));

MsgList.AddObject (‘CM_TIMECHANGE’, TObject(CM_BASE 39));

MsgList.AddObject (‘CM_TABSTOPCHANGED’, TObject(CM_BASE 40));

MsgList.AddObject (‘CM_UIACTIVATE’, TObject(CM_BASE 41));

MsgList.AddObject (‘CM_UIDEACTIVATE’, TObject(CM_BASE 42));

MsgList.AddObject (‘CM_DOCWINDOWACTIVATE’, TObject(CM_BASE 43));

MsgList.AddObject (‘CM_CONTROLLISTCHANGE’, TObject(CM_BASE 44));

MsgList.AddObject (‘CM_GETDATALINK’, TObject(CM_BASE 45));

MsgList.AddObject (‘CM_CHILDKEY’, TObject(CM_BASE 46));

MsgList.AddObject (‘CM_DRAG’, TObject(CM_BASE 47));

MsgList.AddObject (‘CM_HINTSHOW’, TObject(CM_BASE 48));

MsgList.AddObject (‘CM_DIALOGHANDLE’, TObject(CM_BASE 49));

MsgList.AddObject (‘CM_ISTOOLCONTROL’, TObject(CM_BASE 50));

MsgList.AddObject (‘CM_EXECPROC’, TObject($8FFF));

MsgList.AddObject (‘CM_TABFONTCHANGED’, TObject(CM_BASE 100));

MsgList.AddObject (‘CM_DEFERLAYOUT’, TObject(WM_USER 100));

MsgList.AddObject (‘CN_CHARTOITEM’, TObject(CN_BASE WM_CHARTOITEM));

MsgList.AddObject (‘CN_COMMAND’, TObject(CN_BASE WM_COMMAND));

MsgList.AddObject (‘CN_COMPAREITEM’, TObject(CN_BASE WM_COMPAREITEM));

MsgList.AddObject (‘CN_CTLCOLORBTN’, TObject(CN_BASE WM_CTLCOLORBTN));

MsgList.AddObject (‘CN_CTLCOLORDLG’, TObject(CN_BASE WM_CTLCOLORDLG));

MsgList.AddObject (‘CN_CTLCOLOREDIT’, TObject(CN_BASE WM_CTLCOLOREDIT));

MsgList.AddObject (‘CN_CTLCOLORLISTBOX’, TObject(CN_BASE WM_CTLCOLORLISTBOX));

MsgList.AddObject (‘CN_CTLCOLORMSGBOX’, TObject(CN_BASE WM_CTLCOLORMSGBOX));

MsgList.AddObject (‘CN_CTLCOLORSCROLLBAR’, TObject(CN_BASE WM_CTLCOLORSCROLLBAR));

MsgList.AddObject (‘CN_CTLCOLORSTATIC’, TObject(CN_BASE WM_CTLCOLORSTATIC));

MsgList.AddObject (‘CN_DELETEITEM’, TObject(CN_BASE WM_DELETEITEM));

MsgList.AddObject (‘CN_DRAWITEM’, TObject(CN_BASE WM_DRAWITEM));

MsgList.AddObject (‘CN_HSCROLL’, TObject(CN_BASE WM_HSCROLL));

MsgList.AddObject (‘CN_MEASUREITEM’, TObject(CN_BASE WM_MEASUREITEM));

MsgList.AddObject (‘CN_PARENTNOTIFY’, TObject(CN_BASE WM_PARENTNOTIFY));

MsgList.AddObject (‘CN_VKEYTOITEM’, TObject(CN_BASE WM_VKEYTOITEM));

MsgList.AddObject (‘CN_VSCROLL’, TObject(CN_BASE WM_VSCROLL));

MsgList.AddObject (‘CN_KEYDOWN’, TObject(CN_BASE WM_KEYDOWN));

MsgList.AddObject (‘CN_KEYUP’, TObject(CN_BASE WM_KEYUP));

MsgList.AddObject (‘CN_CHAR’, TObject(CN_BASE WM_CHAR));

MsgList.AddObject (‘CN_SYSKEYDOWN’, TObject(CN_BASE WM_SYSKEYDOWN));

MsgList.AddObject (‘CN_SYSCHAR’, TObject(CN_BASE WM_SYSCHAR));

MsgList.AddObject (‘CN_NOTIFY’, TObject(CN_BASE WM_NOTIFY));

end.

unit ViewMsg;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TForm2 = class(TForm)

ListBox1: TListBox;

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form2: TForm2;

implementation

{$R *.DFM}

end.

unit WndProForm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls, ExtCtrls, Buttons;

type

TForm1 = class(TForm)

Button1: TButton;

Edit1: TEdit;

Label1: TLabel;

CheckBox1: TCheckBox;

CheckBox2: TCheckBox;

RadioButton1: TRadioButton;

RadioButton2: TRadioButton;

ListBox1: TListBox;

SpeedButton1: TSpeedButton;

SpeedButton2: TSpeedButton;

SpeedButton3: TSpeedButton;

SpeedButton4: TSpeedButton;

SpeedButton5: TSpeedButton;

SpeedButton6: TSpeedButton;

Bevel1: TBevel;

procedure SpeedButton1Click(Sender: TObject);

procedure SpeedButton2Click(Sender: TObject);

procedure SpeedButton3Click(Sender: TObject);

procedure Button1Click(Sender: TObject);

procedure SpeedButton5Click(Sender: TObject);

private

Last: Integer;

public

procedure WndProc (var Message: TMessage); override;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

uses

ViewMsg, MList;

procedure TForm1.WndProc (var Message: TMessage);

begin

if not (Message.Msg = Last) then

begin

with Form2.Listbox1 do

ItemIndex := Items.Add (GetMessageName (Message.Msg));

Last := Message.Msg;

end;

inherited WndProc (Message);

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

begin

Color := clBlue;

end;

procedure TForm1.SpeedButton2Click(Sender: TObject);

begin

Color := clRed;

end;

procedure TForm1.SpeedButton3Click(Sender: TObject);

begin

Color := clLtGray;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

Caption := Edit1.Text;

end;

procedure TForm1.SpeedButton5Click(Sender: TObject);

var

Pos: Integer;

begin

// exchange Left and Top

Pos := (Sender as TControl).Left;

(Sender as TControl).Left := (Sender as TControl).Top;

(Sender as TControl).Top := Pos;

end;

end.

Загрузить исходный код проекта

{/codecitation}

Многоразовая обработка сообщения

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

unit PostForm;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

StdCtrls;

type

TFormManyMess = class(TForm)

LBox: TListBox;

Button1: TButton;

ButtonPost: TButton;

ButtonSend: TButton;

ButtonPerform: TButton;

ButtonMouseDown: TButton;

ButtonOnMouseDown: TButton;

procedure FormMouseDown(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

procedure Button1Click(Sender: TObject);

procedure FormCreate(Sender: TObject);

procedure ButtonPostClick(Sender: TObject);

procedure ButtonSendClick(Sender: TObject);

procedure ButtonPerformClick(Sender: TObject);

procedure ButtonMouseDownClick(Sender: TObject);

procedure ButtonOnMouseDownClick(Sender: TObject);

private

{ Private declarations }

public

procedure WndProc(var Message: TMessage); override;

procedure DefaultHandler(var Message); override;

procedure WmLButtonDown (var Message: TWMMouse);

message wm_lButtonDown;

procedure MouseDown(Button: TMouseButton;

Shift: TShiftState; X, Y: Integer); override;

procedure ApplicationMessage (var Msg: TMsg;

var Handled: Boolean);

end;

var

FormManyMess: TFormManyMess;

implementation

{$R *.DFM}

procedure TFormManyMess.FormMouseDown(Sender: TObject;

Button: TMouseButton; Shift: TShiftState;

X, Y: Integer);

begin

if Button = mbLeft then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘FormMouseDown’, X, Y]));

end;

procedure TFormManyMess.WndProc(var Message: TMessage);

begin

if Message.Msg = wm_LButtonDown then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘WndProc’, LoWord (Message.LParam),

HiWord (Message.LParam)]));

inherited;

end;

procedure TFormManyMess.DefaultHandler(var Message);

begin

with TMessage (Message) do

if Msg = wm_LButtonDown then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘DefaultHandler’, LoWord (LParam),

HiWord (LParam)]));

inherited;

end;

procedure TFormManyMess.WmLButtonDown (var Message: TWMMouse);

begin

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘WmLButtonDown’, Message.XPos, Message.YPos]));

inherited;

end;

procedure TFormManyMess.MouseDown(Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

begin

if Button = mbLeft then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘MouseDown’, X, Y]));

inherited;

end;

procedure TFormManyMess.ApplicationMessage (var Msg: TMsg;

var Handled: Boolean);

begin

if (Msg.Message = wm_LButtonDown) and

(Msg.hWnd = Handle) then

LBox.Items.Add (Format (‘%s in (%d, %d)’,

[‘ApplicationMessage’, LoWord (Msg.LParam),

HiWord (Msg.LParam)]));

Handled := False;

end;

procedure TFormManyMess.FormCreate(Sender: TObject);

begin

Application.OnMessage := ApplicationMessage;

end;

procedure TFormManyMess.Button1Click(Sender: TObject);

begin

LBox.Clear;

end;

procedure TFormManyMess.ButtonPostClick(Sender: TObject);

begin

LBox.Items.Add (‘ — PostMessage —‘);

PostMessage (Handle, wm_lButtonDown,

0, MakeLong (10, 10));

PostMessage (Handle, wm_lButtonUp,

0, MakeLong (10, 10));

end;

procedure TFormManyMess.ButtonSendClick(Sender: TObject);

begin

LBox.Items.Add (‘ — SendMessage —‘);

SendMessage (Handle, wm_lButtonDown,

0, MakeLong (10, 10));

SendMessage (Handle, wm_lButtonUp,

0, MakeLong (10, 10));

end;

procedure TFormManyMess.ButtonPerformClick(Sender: TObject);

begin

LBox.Items.Add (‘ — Perform —‘);

Perform (wm_lButtonDown,

0, MakeLong (10, 10));

Perform (wm_lButtonUp,

0, MakeLong (10, 10));

end;

procedure TFormManyMess.ButtonMouseDownClick(Sender: TObject);

begin

LBox.Items.Add (‘ — MouseDown —‘);

MouseDown (mbLeft, [], 10, 10);

end;

procedure TFormManyMess.ButtonOnMouseDownClick(Sender: TObject);

begin

LBox.Items.Add (‘ — OnMouseDown —‘);

OnMouseDown (self, mbLeft, [], 10, 10);

end;

end.

Загрузить исходный код проекта

{/codecitation}

Как отловить сообщения о прокрутке TScrollBar

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Олег Кулабухов

Нижеприведенный пример передвигает второй ScrollBar на такое же количество едениц, на которое передвинет пользователь первый. Т.е. синхронизирует их.

type

{$IFDEF WIN32}

WParameter = LongInt;

{$ELSE}

WParameter = Word;

{$ENDIF}

LParameter = LongInt;

{Declare a variable to hold the window procedure we are replacing}

var

OldWindowProc: Pointer;

function NewWindowProc(WindowHandle: hWnd;

TheMessage: WParameter;

ParamW: WParameter;

ParamL: LParameter): LongInt

{$IFDEF WIN32} stdcall;

{$ELSE}; export;

{$ENDIF}

var

TheRangeMin: integer;

TheRangeMax: integer;

TheRange: integer;

begin

if TheMessage = WM_VSCROLL then

begin

{Get the min and max range of the horizontal scroll box}

GetScrollRange(WindowHandle,

SB_HORZ,

TheRangeMin,

TheRangeMax);

{Get the vertical scroll box position}

TheRange := GetScrollPos(WindowHandle,

SB_VERT);

{Make sure we wont exceed the range}

if TheRange < TheRangeMin then

TheRange := TheRangeMin

else if TheRange > TheRangeMax then

TheRange := TheRangeMax;

{Set the horizontal scroll bar}

SetScrollPos(WindowHandle,

SB_HORZ,

TheRange,

true);

end;

if TheMessage = WM_HSCROLL then

begin

{Get the min and max range of the horizontal scroll box}

GetScrollRange(WindowHandle,

SB_VERT,

TheRangeMin,

TheRangeMax);

{Get the horizontal scroll box position}

TheRange := GetScrollPos(WindowHandle,

SB_HORZ);

{Make sure we wont exceed the range}

if TheRange < TheRangeMin then

TheRange := TheRangeMin

else if TheRange > TheRangeMax then

TheRange := TheRangeMax;

{Set the vertical scroll bar}

SetScrollPos(WindowHandle,

SB_VERT,

TheRange,

true);

end;

{ Call the old Window procedure to }

{ allow processing of the message. }

NewWindowProc := CallWindowProc(OldWindowProc,

WindowHandle,

TheMessage,

ParamW,

ParamL);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

{ Set the new window procedure for the control }

{ and remember the old window procedure. }

OldWindowProc := Pointer(SetWindowLong(ScrollBox1.Handle,

GWL_WNDPROC,

LongInt(@NewWindowProc)));

end;

procedure TForm1.FormDestroy(Sender: TObject);

begin

{ Set the window procedure back }

{ to the old window procedure. }

SetWindowLong(ScrollBox1.Handle,

GWL_WNDPROC,

LongInt(OldWindowProc));

end;

{/codecitation}

Как отловить момент окончания изменения размеров компонента

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

В следующем примере показан перехват сообщения WM_EXITSIZEMOVE Хотя сообщение документированно только для Windows NT оно работает точно так же и под Windows 95. Обратите внимание что Вы можите перехватить сообщение WM_ENTERSIZEMOVEдля определения момента начала пользователем операции изменения размера или перемещения окна.

type

TForm1 = class(TForm)

private

{ Private declarations }

public

{ Public declarations }

procedure WMEXITSIZEMOVE(var message: TMessage); message WM_EXITSIZEMOVE;

end;

var

Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.WMEXITSIZEMOVE(var message: TMessage);

begin

Form1.Caption := ‘Finished Moving and sizing’;

end;

{/codecitation}

Как обрабатывать сообщения

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Обработка сообщений означает, что приложение будет тем или иным образом реагировать на полученные от операционной системы сообщения. В стандартном приложении Windows обработка сообщений сосредотачивается в процедурах окна. Delphi, частично обрабатывая сообщения, упрощает работу программиста, позволяя вместо одной процедуры для обработки всех типов сообщений создавать независимые процедуры для обработки сообщений различных типов.

Все процедуры обработки сообщений должны отвечать следующим требованиям:

Процедура должна быть методом объекта

Процедуре должен передаваться один передаваемый по ссылке параметр, т.е. с помощью описания var. Тип параметра должен быть TMessage или другой, зависящий от типа специализированного сообщения

Описание процедуры должно включать ключевое слово message, за которым должна следовать константа, задающая тип обрабатываемого сообщения

Вот пример объявления процедуры, обрабатывающей сообщение WM_Paint

procedure WMPaint(var Msg: TWMPaint); message wm_Paint;

[соглашение по присвоению имён требует присваивать обработчику сообщения то же имя, что и имя обрабатываемого сообщения, но без символа подчёркивания и указанием первым знаков имени прописными буквами]

В качестве примера напишем процедуру обработки сообщения WM_Paint, которая вместо перерисовки будет выдавать звуковой сигнал:

Для этого сначала нужно объявить процедуру в частных объявлениях (в области Private объекта TForm1):

procedure WMPaint(var Msg: TWMPaint); message wm_Paint;

Теперь в разделе implementation модуля добавляем определение процедуры (в этом случае указание ключевого слова message не требуется):

procedure TForm1.WMPaint(var Msg: TWMPaint);

begin

beep;

inherited;

end;

Обратите внимание на ключевое слово inherited, которое позволяет передать сообщение обработчику этого сообщения, принадлежащему классу-предку, т.е. если бы мы в нашем случае не указали бы это слово, перерисовка окна не осуществлялась бы, а выполнялось бы только только то, что было описано в области реализации нашего приложения, т.е. только бы подавался звуковой сигнал.

{/codecitation}

Как обнаружить активность юзера

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Сынишка системного администратора вечером просит папу:

— Па. Почитай на ночь сказку про умного, толкового, доброго, смелого юзерa…

Application.OnMessage := DoMessageEvent;

procedure TForm1.DoMessageEvent(var Msg: TMsg; var Handled: Boolean);

begin

case Msg.message of

WM_KEYFIRST..WM_KEYLAST,

WM_MOUSEFIRST..WM_MOUSELAST:

{ Произошли события клавиатуры и мыши };

end;

end;

{/codecitation}

Как запрограммировать Undo

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Встречаются два программиста — один идет веселый, пьет пиво, а второй — грустный, но с коляской. Первый:

— Ты чего такой? Жизнь прекрасна!

Второй (указывая на коляску):

— Да вот!.. Ни Uninstall, ни Undo не помогли

Memo1.Perform(EM_UNDO, 0, 0);

{/codecitation}

Занесение сообшения в EventLog (Windows NT)

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Автор: Alex V. Novikov

Черт гуляет по чистилищу. В 1-ю дверь заходит, там крики, кого-то плетью хлещут. Во 2-ю заходит, там кого-то в котле варят. Заходит в 3-ю, там сидит за компьютером какой-то мужичок, тишина, спокойствие. Черт в недоумении бежит к Дьяволу.

— Чего там за такое?

— А, это? Да это Билл Гейтс. Его приговили программы для «Линукса» писать!!!

Я постоянно читаю конференции по дельфи и частенько встечается вопрос как занести свое сообщение в EventLog Windows NT. Недавно покопавшись в исходниках VCL я обнаружил такой интересный класс:

Unit SvcMgr;

{—Skip—}

{ TEventLogger }

TEventLogger = class(TObject)

private

FName: String;

FEventLog: Integer;

public

constructor Create(Name: String);

destructor Destroy; override;

procedure LogMessage(Message: String; EventType: DWord = 1;

Category: Word = 0; ID: DWord = 0);

end;

{—Skip—}

С помощью этого класса можно легко заносить свои сообщения в EventLog, правда этот класс был замечен мною только в Delphi 5, на счет других версий я не уверен.

Пример использования:

with TEventLogger.Create(‘My Application’) do

try

LogMessage(‘Страшенная ошибка’);

finally

Free;

end;

P.S. надеюсь это кому нибудь поможет

{/codecitation}

Два простых способа уведомления

{codecitation class=»brush: pascal; gutter: false;» width=»600px»}

Оформил: DeeCo

Автор: Алексей Еремеев

В своей работе мне частенько приходиться делать разного рода клиент-серверные системы.

И совсем не обязательно на уровне глобальных сетей. Речь пойдет о внутренних подсистемах.

Например, имеем компонент, который эмулирует секундомер. Запустили его с параметром типа «а напомни мне, что будет полночь» и забыли. Ну и конечно событие есть типа OnAlert. И обработчик его честно будет вызван по достижении нужной нам полуночи. Но обработчик один, а захотели узнать об этом событии сразу десять разных объектов. Не вешать же десять будильников?

Конечно, проще в одном обработчике перебрать методы уведомления этих десяти объектов да и дело с концом. Но можно поступить хитрее — заставить объект-будильник самому напоминать всем кто попросит его об этом. Вот о способах такого уведомления и пойдет речь.

Как условие — объект «сервер» ничего не знает об объекте «клиенте». После некоторого размышления и перебрав несколько вариантов я пришел к выводу, что наиболее приемлимые для практики есть два способа. Первый подсмотрен в WinAPI а второй — чисто Дельфи. Оба способа основаны на простой идее регистрации клиента на сервере и оповещении сервером клиентов по внутреннему списку зарегистрированных клиентов.

Способ 1. Оповещение через механизм сообщений Windows.

в модуле объекта-сервера в интерфейсной части определяется пользовательский номер события:

const

WM_NOTIFY_MSG = WM_USER 123;

в объекте-сервере реализуются две интерфейсные процедуры (вкупе с объявленным в приватной секции и созданным в конструкторе TList, в деструкторе не забудем его разрушить, естественно)

procedure RegisterHandle(HW: THandle);

var

i: integer;

begin

i := FWindList.IndexOf(pointer(HW));

if i < 0 then

FWinList.Add(pointer(HW));

end;

procedure UnregisterHandle(HW: THandle)

var

i: integer;

begin

i := FWindList.IndexOf(pointer(HW));

if i >= 0 then

FWinList.Delete(i);

end;

и создается функция оповещения в приватной секции:

procedure SendNotify(wParam, lParam: integer);

var

i: integer;

begin

i := 0;

while i < FWinList.Count do

begin

SendMessage(integer(FWinList.Items[i]), WM_NOTIFY_MSG, wParam, lParam);

Inc(i);

end;

end;

можно вместо SendMessage использовать PostMessage, будет асинхронное сообщение, иногда это выгодней, например для исключения возможности бесконечной рекурсии.

Объект-клиент должен иметь хэндл окна, который регистрируется на объекте-сервере и обработчик событий этого окна, который будет вызыватся при оповещении сервером списка клиентов (окон).

У объекта-клиента можно поступить двояко. Если объект-клиент уже имеет хэндл окна (например, форма) то пишется обработчик фиксированного номера события:

procedure ServMsg(var Msg: TMessage); message WM_NOTIFY_MSG;

или если окна нет, то создается универсальный метод-обработчик и невидимое окно при помощи функции AllocateHWND() (пример смотрите в исходниках VCL — объект TTimer)

Прелесть этого метода состоит в том, что объект-клиент может быть вообще в другом приложении, нежели объект-сервер, и такой трюк пройдет при использовании DLL. Кроме того передавать можно не только пару цифр, но и блоки данных (и даже строки) при помощи сообщения WM_COPYDATA.

Но это уже другая история, а мы пока пойдем дальше.

Способ 2. Оповещение через объект-посредник.

В отдельном модуле создаем объект-посредник, который имеет один метод типа SendEvent и одну ссылку на обработчик события OnEvent. Я назвал такой объект TSynaps (да простят меня нейрохирурги)

unit Synaps;

interface

uses

Windows, Messages, SysUtils, Classes;

type

TSynaps = class(TObject)

private

FOnEvent: TNotifyEvent;

public

procedure SendEvent;

property OnEvent: TNotifyEvent read FOnEvent write FOnEvent;

end;

implementation

procedure SendEvent;

begin

if Assigned(FOnEvent) then

try

FOnEvent(Self);

except

end;

end;

end;

Причем методов и событий может быть много разных на любой вкус. С очередями, асинхронными «прослойками», задержками и другими наворотами. Тут уж кто на что горазд. Я лишь демонстрирую идею. Модуль с объектом-сервером и модуль с объектом-клиентом имеют право знать о модуле Synaps. В объекте-сервере реализуются уже знакомые нам три функции (чуть иначе):

в интерфейсе объекта:

procedure RegisterSynaps(Syn: TSynaps);

var

i: integer;

begin

i := FSynapsList.IndexOf(pointer(Syn));

if i < 0 then

FSynapsList.Add(pointer(Syn));

end;

procedure UnregisterSynaps(Syn: TSynaps);

var

i: integer;

begin

i := FSynapsList.IndexOf(pointer(Syn));

if i >= 0 then

FSynapsList.Delete(i);

end;

и приватная функция:

procedure NotifySynapses;

var

i: integer;

begin

i := 0;

while i < FSynapsList.Count do

begin

TSynaps(FSynapsList.Items[i]).SendEvent;

Inc(i);

end;

end;

Объект-клиент создает в себе объект-синапс, назначает его событию OnEvent свой внутренний обработчик и регистрирует этот синапс на объекте-сервере. Вуаля! И получает оттуда уведомления. Кстати, в деструктор синапса можно встроить вызов события OnDestroy, и тогда объект-сервер, при регистрации клиента, может назначить ему обработчик и автоматически разрегистрировать его при уничтожении. Но это уже навороты.

Такой подход позволяет строить обратные вызовы любой сложности. К тому-же это чистый паскаль-код без привязки к операционке. (а вдруг Kylix :о)

Итог.

Как вы могли заметить, оба способа базируются на двух базовых идеях. Первое — это регистрация клиента на сервере, и второе — вызов сервером некой функции внутри клиента. Разница только в механизмах. И выбирать тут можно исходя из вкусов, предпочтений и неких требований, связанных с ресурсоемкостью, переносимостью и т. п.

На самом деле есть очень широко распространенный и давно известный метод под названием CallBack-функция.

Мы вызываем кого-то и передаем как один из параметров адрес другой функции. И этот метод частенько используется в WinAPI (смотрите, к примеру, справку по функции EnumFonts). Но! Механизм прямого CallBack-а довольно некрасиво ложится на объектную модель Дельфи, так что я не стал описывать его здесь. Тем более, что оба способа — то-же самое, но красивше. И самое последнее — не забывайте разрегистрировать клиента в конце работы и освобождать ресурсы в деструкторе. И да известят вас ваши сервера только о хорошем!

{/codecitation}