Форум на Исходниках.RU

{$IFDEF MSWINDOWS}

type

// AllocWnd types

TWndProcMethod = function(wnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT of object;

TWndProc = function(wnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;

{$ENDIF}

...

{$IFDEF MSWINDOWS}

// message window

function AllocateMsgWnd(Handler: TWndProcMethod): HWND; overload;

function AllocateMsgWnd(Handler: TWndProc): HWND; overload;

procedure DeallocateMsgWnd(Wnd: HWND); inline;

{$ENDIF}

...

{$IFDEF MSWINDOWS}

// ********* AllocWnd *********** \

// Служит для создания окна, предназначенного для отправки/получения сообщений.

// ! Хэндл окна должен быть закрыт посредством DestroyWindow/DeallocateMsgWnd !

// Метод-обработчик сообщений можно и не указывать, в этом случае сообщения

// будут приходить в message loop потока-владельца

type

TWndProcType = (wpMethod, wpProc);

TWndProcInst = record

case ProcType: TWndProcType of

wpMethod: (WndProcMethod: TWndProcMethod);

wpProc : (WndProc : TWndProc);

end;

PWndProcInst = ^TWndProcInst;

const WndProcProp = 'WndProcProp';

// Новая оконная процедура, извлекающая указатель на метод-обработчик из свойства окна

function DefWndProc(wnd: HWND; msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;

var pInst: PWndProcInst;

begin

pInst := PWndProcInst(GetProp(wnd, PChar(WndProcProp)));

// вызываем обработчик: метод класса/сохранённая процедура либо дефолтная функция

if pInst = nil

then Result := DefWindowProc(wnd, msg, wParam, lParam)

else case pInst.ProcType of

wpMethod: Result := pInst.WndProcMethod(wnd, msg, wParam, lParam);

wpProc : Result := pInst.WndProc(wnd, msg, wParam, lParam);

else Result := 0; // make compiler happy

end;

// если окно уничтожается - удалить свойство и освободить память, выделенную под запись

if msg = WM_DESTROY then

begin

RemoveProp(wnd, PChar(WndProcProp));

if pInst <> nil then FreeMem(pInst);

end;

// Создание окна-обработчика сообщений

function InnerAllocateMsgWnd(pInst: PWndProcInst): HWND;

var err: Integer;

begin

Result := CreateWindowEx(0, 'Button', nil,0,0,0,0,0, HWND_MESSAGE, 0, HInstance, nil);

if Result = 0 then Exit;

// сохранить указатель на метод класса - обработчик сообщений

if (not SetProp(Result, PChar(WndProcProp), THandle(pInst))) or

// заменить оконную процедуру

(SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@DefWndProc)) = 0) then

begin

err := GetLastError;

DestroyWindow(Result);

Result := 0;

SetLastError(err);

end;

function AllocateMsgWnd(Handler: TWndProcMethod): HWND;

var pInst: PWndProcInst;

begin

if not Assigned(Handler) then

pInst := nil

else

begin

pInst := AllocMem(SizeOf(TWndProcInst));

pInst.ProcType := wpMethod;

pInst.WndProcMethod := Handler;

end;

Result := InnerAllocateMsgWnd(pInst);

if (Result = 0) and (pInst <> nil) then FreeMem(pInst);

end;

function AllocateMsgWnd(Handler: TWndProc): HWND;

var pInst: PWndProcInst;

begin

if not Assigned(Handler) then

pInst := nil else

begin

pInst := AllocMem(SizeOf(TWndProcInst));

pInst.ProcType := wpProc;

pInst.WndProc := Handler;

end;

Result := InnerAllocateMsgWnd(pInst);

if (Result = 0) and (pInst <> nil) then FreeMem(pInst);

end;

// просто обертка для тех, кому привычнее

procedure DeallocateMsgWnd(Wnd: HWND);

begin

DestroyWindow(Wnd);

end;

{$ENDIF}

// объявление и создание ( 1 - обработчик - метод класса, 2 - обработчик - обычная функция )

TSomeClass = class

FHwnd: THandle;

function WndProc(wnd: hWnd; msg, wParam, lParam: Longint): Longint;

end;

2) —

...

1) SomeObject : TSomeClass;

Hw: HWND;

function SomeWndProc(wnd: hWnd; msg, wParam, lParam: Longint): Longint;

begin

...

Result := 0;

end;

...

SomeObject.FHwnd := AllocateMsgWnd(SomeObject.WndProc);

if SomeObject.FHwnd = 0 then Log(SysErrorMessage(GetLastError));

Hw := AllocateMsgWnd(SomeWndProc);

if Hw = 0 then Log(SysErrorMessage(GetLastError));

...

// Посылка сообщений

1) SendMessage(SomeObject.FHwnd, WM_TIMER, 0, 0);

2) SendMessage(Hw, WM_TIMER, 0, 0);

...

// Удаление окна

1) DestroyWindow(SomeObject.FHwnd);

2) DestroyWindow(Hw);