Заюзать метод класса как WindowProc

← →
SpellCaster (2008-03-26 13:47) [0]

Возникла такая надобность: создать окошко для приёма сообщений для каждого экземпляра класса. По определённым причинам пользоваться AllocateWnd не хочется. Решил воплотить такую схему:
1) При создании объекта создается окно с WindowProc, указывающим на
function InnerWndProc(wnd: hWnd; msg, wParam, lParam: Longint): Longint; stdcall;
2) После этого в пользовательскую инфу окна заносится Self
3) При поступлении мессаги в InnerWndProc из польз. инфы окна извлекается Self и вызывается Self.WndProc

ИМХО, вполне неплохое и удобное решение. Проблема в том, что окно создаваться не желает, причём как-то хаотически. Код создания окна:
constructor TMyClass.Create; var WndClass: TWndClass; ClName: string; begin inherited; FillChar(WndClass,SizeOf(WndClass),0); ClName:=ClassName; if not GetClassInfo(HInstance,PChar(ClName),WndClass) then begin WndClass.hInstance := HInstance; WndClass.lpfnWndProc := @InnerWndProc; WndClass.lpszClassName := PChar(ClName); if windows.RegisterClass(WndClass)=0 then Error(SysErrorMessage(GetLastError)); end; fHwnd:=CreateWindowEx(WS_EX_TOOLWINDOW,WndClass.lpszClassName,"",WS_POPUP, 0,0,0,0,0,0,HInstance,nil); if fHwnd=0 then Error(SysErrorMessage(GetLastError)); SetWindowLong(fHwnd,GWL_USERDATA,Integer(Self)); end;

Вот такая процедура работает

function InnerWndProc(wnd: hWnd; msg, wParam, lParam: Longint): Longint; stdcall; var m: TMessage; res: Integer; begin m.Msg:=msg; m.WParam:=wParam; m.LParam:=lParam; res:=GetWindowLong(wnd,GWL_USERDATA); if res=0 then begin res:=GetLastError; MessageBox(0,pchar(SysErrorMessage(res)),"",mb_ok); end else TMyClass(pointer(res)).WndProc(m); end;

но стоит закомментить строки с MessageBox - CreateWindowEx возвращает 0, причем код ошибки - тоже 0!
Вот такая конструкция тоже работает
function InnerWndProc(wnd: hWnd; msg, wParam, lParam: Longint): Longint; stdcall; var m: TMessage; res: Integer; begin m.Msg:=msg; m.WParam:=wParam; m.LParam:=lParam; end;
но толку с нее, очевидно, нету.

Что тут за грабли могут быть?

← →
SpellCaster (2008-03-26 13:52) [1]

А, и самое странное в том, что если я это делаю в главном модуле, то все прекрасно действует

function InnerWndProc(wnd: hWnd; msg, wParam, lParam: Longint): Longint; stdcall; var m: TMessage; res: Integer; begin m.Msg:=msg; m.WParam:=wParam; m.LParam:=lParam; res:=GetWindowLong(wnd,GWL_USERDATA); if res=0 then form1.Memo1.Lines.Add((SysErrorMessage(GetLastError))) else tform1(pointer(res)).Somemethod(0); end; procedure wnd; var WndClass: TWndClass; ClassRegistered: Boolean; ClName: string; w: TWndMethod; fHwnd: HWND; begin FillChar(WndClass,SizeOf(WndClass),0); ClName:="qwe"; ClassRegistered := GetClassInfo(HInstance,PChar(ClName),WndClass); if not ClassRegistered then begin WndClass.hInstance := HInstance; WndClass.lpfnWndProc := @InnerWndProc; WndClass.lpszClassName := PChar(ClName); if windows.RegisterClass(WndClass)=0 then raise exception.Create(SysErrorMessage(GetLastError)); end; fHwnd:=CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName,"", WS_MINIMIZE, 0, 0, 0, 0, 0, 0, HInstance, nil); if fHwnd=0 then raise exception.Create(SysErrorMessage(GetLastError)); SetWindowLong(fHwnd,GWL_USERDATA,Integer(form1)); sendmessage(fhwnd,WM_MOVE,0,0); end; procedure TForm1.FormCreate(Sender: TObject); begin wnd; end;

← →
Игорь Шевченко © (2008-03-26 14:13) [2]

Уж сколько раз твердили миру:

MyWnd := CreateWindow ("myclass", "mycaption",
WS_OVERLAPPEDWINDOW,
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
HWND_DESKTOP, 0,
HInstance, Self);

в оконной процедуре:

function MyWndProc (Window: HWND; Message, WParam: Cardinal;
LParam: Cardinal): Longint; stdcall;
var
MainClass : TMainWindow;
...
begin
MainClass := TMainWindow(GetWindowLong (Window, GWL_USERDATA));
case Message of
WM_CREATE:
begin
MainClass := TMainWindow(PCreateStruct(LParam)^.lpCreateParams);
SetWindowLong (Window, GWL_USERDATA, Integer(MainClass));
Result := 0;
end;
...........
end;

← →
Reindeer Moss Eater © (2008-03-26 14:19) [3]

AllocateHWnd

← →
guav © (2008-03-26 14:47) [4]

Вот почему разрабочики Delphi не пошли по такому пути, а создают код оконного метода динамически ?

← →
Игорь Шевченко © (2008-03-26 15:35) [5]

> Вот почему разрабочики Delphi не пошли по такому пути, а
> создают код оконного метода динамически ?

А им uses Classes незазорно втыкать

← →
DVM © (2008-03-26 16:20) [6]

function TSCMPBaseClient.AllocWnd: HWND;
var
wc: TWndClassEx;
WndClassName: string;
begin
result := 0;
FObjectInstance := VirtualAlloc(nil, 12, MEM_RESERVE or MEM_COMMIT, PAGE_EXECUTE_READWRITE);
asm
mov EAX, Self
mov ECX, [EAX].TSCMPBaseClient.FObjectInstance
mov word ptr [ECX+0], $6858
mov dword ptr [ECX+2], EAX
mov word ptr [ECX+6], $E950
mov EAX, OFFSET(TSCMPBaseClient.WndProc)
sub EAX, ECX
sub EAX, 12
mov dword ptr [ECX+8], EAX
end;
Str(DWord(Self), WndClassName);
WndClassName := ClassName + ":" + WndClassName;
ZeroMemory(@wc, SizeOf(wc));
wc.cbSize := SizeOf(Wc);
wc.style := CS_HREDRAW or CS_VREDRAW;
wc.hInstance := hInstance;
wc.lpfnWndProc := FObjectInstance;
wc.lpszClassName := pchar(WndClassName);
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
if Windows.RegisterClassEx(wc) = 0 then exit;
result := CreateWindowEx(WS_EX_TOOLWINDOW, pchar(WndClassName), "clientwnd", WS_POPUP, 0, 0, 0, 0, 0, 0, HInstance, nil);
end;

← →
DVM © (2008-03-26 16:21) [7]

procedure TSCMPBaseClient.DeAllocWnd;
begin
if FWindowHandle <> 0 then DestroyWindow(FWindowHandle);
VirtualFree(FObjectInstance, 0, MEM_RELEASE);
end;

function WndProc(Wnd: THandle; Msg: Cardinal; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;

← →
DVM © (2008-03-26 16:22) [8]

WndProc - метод класса TSCMPBaseClient в моем случае

← →
guav © (2008-03-26 16:38) [9]

> [5] Игорь Шевченко © (26.03.08 15:35)

Я не про то, где это реализовано, я про саму реализацию.
Чем реализация вроде [6] оказалась лучше реализации вроде [2] ?
Я только вижу добавленую проблему пре переходе на другую архитектру процессора.

← →
DVM © (2008-03-26 16:50) [10]

> Я только вижу добавленую проблему пре переходе на другую
> архитектру процессора.

А какая еще может быть другая архитектура у связки Windows + Delphi, кроме x86-32 и x86-64 ?

← →
SpellCaster (2008-03-26 17:03) [11]

> [2] Игорь Шевченко © (26.03.08 14:13)

Спасибо, не додумался до такого! Сейчас попробую

> [3] Reindeer Moss Eater © (26.03.08 14:19)

Это как раз то, от чего я хочу уйти

> [6] DVM © (26.03.08 16:20)

У тебя, насколько я понимаю, некий аналог AllocateWnd - то же выделение объекта и тот же хак с подменой адресов. Благодарю, однако хочется без читов :)

----

Блин, я балбес :( совсем забыл WinAPI, там ведь надо дефолтную процедуру вызывать, если мессага не обработана. Конечно, мне приходила WM_NCCREATE, а я на нее ничего не возвращал (т.е. 0 по дефолту), вот окно и удалялось

← →
guav © (2008-03-26 17:17) [12]

> [10] DVM © (26.03.08 16:50)

Мало ли, может реализуют копиляцию 64разрядных бинарников для x86-64.

Меня больше интересует какие недостатки у более прямого пути, без asm кода.

← →
SpellCaster (2008-03-26 17:37) [13]

> [12] guav © (26.03.08 17:17)

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

Итак, вся трабла действительно была в отсутствии дефолтной оконной процедуры! Вот работающий кусок кода:

function InnerWndProc(wnd: hWnd; msg, wParam, lParam: Longint): Longint; stdcall; var m: TMessage; res: Integer; begin if msg = WM_MYMSG then begin Result:=0; m.Msg:=msg; m.WParam:=wParam; m.LParam:=lParam; res:=GetWindowLong(wnd,GWL_USERDATA); if res<>0 then TMyClass(Pointer(res)).WndProc(m); end else Result:=DefWindowProc(wnd,msg,wparam,lparam); end; constructor TMyClass.Create; var WndClass: TWndClass; ClName: string; begin inherited; // создаём окно, куда будут приходить все мессаги FillChar(WndClass,SizeOf(WndClass),0); ClName:=ClassName; if not GetClassInfo(HInstance,PChar(ClName),WndClass) then begin windows.UnregisterClass(PChar(ClName),HInstance); WndClass.hInstance := HInstance; WndClass.lpfnWndProc := @InnerWndProc; WndClass.lpszClassName := PChar(ClName); if windows.RegisterClass(WndClass)=0 then Error(SysErrorMessage(GetLastError)); end; fHwnd:=CreateWindow(PChar(ClName),"",WS_OVERLAPPEDWINDOW, CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT, HWND_DESKTOP, 0, HInstance, nil); if fHwnd=0 then Error(SysErrorMessage(GetLastError)); SetWindowLong(fHwnd,GWL_USERDATA,Integer(Self)); SendMessage(fhwnd,WM_MYMSG,123,123); // проверка! end;

Единственная странность, что при использовании CreateWindowEx c абсолютно теми же параметрами я получал ошибку "Не могу найти указанный файл". Но разбираться не хочется, раз CreateWindow отлично пашет.

← →
SpellCaster (2008-03-26 18:01) [14]

И еще одно решение - промежуточная функция внутри класса. Сделано через статический метод класса, поэтому только для БДС2006 и выше.

class TMyClass ... class function WndProcSt(wnd: hWnd; msg, wParam, lParam: Longint): Longint; stdcall; static; ... end constructor TMyClass.Create(TimOut, sckt: Integer; pAddr: PSockAddrIn); type Twndproc = function (wnd: hWnd; msg, wParam, lParam: Longint): Longint of object; stdcall; var WndClass: TWndClass; ClName: string; w: Twndproc; begin ... WndClass.hInstance := HInstance; w:=wndprocst; WndClass.lpfnWndProc := @w; ... end; class function TMyClass.WndProcSt(wnd: hWnd; msg, wParam, lParam: Integer): Longint; var m: TMessage; res: Integer; begin if msg = WM_MYMSG then begin Result:=0; m.Msg:=msg; m.WParam:=wParam; m.LParam:=lParam; res:=GetWindowLong(wnd,GWL_USERDATA); if res<>0 then //Result:= TMyClass(Pointer(res)).WndProc(m); end else Result:=DefWindowProc(wnd,msg,wparam,lparam); end;

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

← →
Игорь Шевченко © (2008-03-26 20:08) [15]

> fHwnd:=CreateWindow(PChar(ClName),"",WS_OVERLAPPEDWINDOW,
>
> CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,
> CW_USEDEFAULT,
> HWND_DESKTOP, 0, HInstance, nil);
> if fHwnd=0 then Error(SysErrorMessage(GetLastError));
> SetWindowLong(fHwnd,GWL_USERDATA,Integer(Self));

В обработке WM_CREATE надо ставить данные в GWL_USERDATA

← →
DVM © (2008-03-26 21:08) [16]

> SpellCaster

При создании нескольких экземпляров класса проблем нету никаких?

← →
han_malign © (2008-03-27 11:40) [17]

> Вот почему разрабочики Delphi не пошли по такому пути, а создают код оконного метода динамически ?

- потому, что кому-то GWL_USERDATA может понадобиться для других целей...

← →
SpellCaster (2008-03-27 11:41) [18]

> [15] Игорь Шевченко © (26.03.08 20:08)

А почему именно так, скажи пожалуйста. Почему нельзя ставить после создания окна?
> [16] DVM © (26.03.08 21:08)

Сейчас сделал 100 штук, вроде работают

← →
SpellCaster (2008-03-27 11:43) [19]

> потому, что кому-то GWL_USERDATA может понадобиться для
> других целей...

Так в том-то и фишка, что они и так туда пихают указатель! Только теперь уже на некий фейковый объект.

← →
Игорь Шевченко © (2008-03-27 11:48) [20]

> А почему именно так, скажи пожалуйста. Почему нельзя ставить
> после создания окна?

потому что от момента вызова CreateWindow(Ex) до момента возврата из нее, в оконную процедуру приходит масса сообщений. И вполне вероятно, что некоторые потребуется обработать, уже имея указатель на класс, связанный с окном.

← →
han_malign © (2008-03-27 12:17) [21]

> Так в том-то и фишка, что они и так туда пихают указатель! Только теперь уже на некий фейковый объект.

Да ну? А кусок кода слабо привести где они GWL_USERDATA используют? В D7 и BDS2006 я что-то не нашел...

← →
SpellCaster (2008-03-27 12:48) [22]

> [21] han_malign © (27.03.08 12:17)

RTFM...
function AllocateHWnd(Method: TWndMethod): HWND; var TempClass: TWndClass; ClassRegistered: Boolean; begin UtilWindowClass.hInstance := HInstance; {$IFDEF PIC} UtilWindowClass.lpfnWndProc := @DefWindowProc; {$ENDIF} ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName, TempClass); if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then begin if ClassRegistered then Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance); Windows.RegisterClass(UtilWindowClass); end; Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName, "", WS_POPUP {+ 0}, 0, 0, 0, 0, 0, 0, HInstance, nil); if Assigned(Method) then SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method))); end;

← →
SpellCaster (2008-03-27 12:52) [23]

> [20] Игорь Шевченко © (27.03.08 11:48)

В общем случае - согласен, разумно. Однако в моём случае нужное сообщение только одно, и до определенного момента оно просто не приходит.

← →
SpellCaster (2008-03-27 12:53) [24]

> [22] SpellCaster (27.03.08 12:48)

А, ну да, они там GWL_WNDPROC подменяют, прошу прощения.

> Уж сколько раз твердили миру:
>
> MyWnd := CreateWindow ("myclass", "mycaption",
> WS_OVERLAPPEDWINDOW,
> Integer(CW_USEDEFAULT),
> Integer(CW_USEDEFAULT),
> Integer(CW_USEDEFAULT),
> Integer(CW_USEDEFAULT),
> HWND_DESKTOP, 0,
> HInstance, Self);

- вообще, почитав MSDN, тут лучше перестраховаться и передавать указатель на структуру
packed record
size: word;
_self: TObject;
....
end;
- потому как не исключено, что это дело нацеливалось на копирование пользовательских данных... скорее всего, конечно, для валидации, но если в очередном сервис-паке Висты все нагнется - я сильно не удивлюсь.

← →
SpellCaster (2008-11-19 13:35) [27]

Набрел на еще один способ: случайно узнал о таких полезных функциях, как Get/SetProp. Теперь можно присваивать так:
SetProp(wnd,PropName,LParam(Self));
и извлекать
obj := TMyObject(Pointer(GetProp(wnd,PropName))); if obj = nil then Result := False else Result := obj.DialogProc(wnd, msg, wParam, lParam);

> guav © (26.03.08 17:17) [12]

> Меня больше интересует какие недостатки у более прямого
> пути, без asm кода.

Не понял, что есть "прямой", но GetWindowLong - медленней.
Как, впрочем, и GetProp.

--
Regards, LVT.

> SpellCaster (26.03.08 17:03) [11]

> У тебя, насколько я понимаю, некий аналог AllocateWnd -
> то же выделение объекта и тот же хак с подменой адресов.
> Благодарю, однако хочется без читов :)

Сам ты хак и чит.
AllocateWnd выделяет память честно - for execute.
И не подмена, а выделение функции ок. проц. для каждого экз. класса.

Вот, те кто реализовывал ок. проц. на стеке - тот пострадал.
Может даже MFC or SWL, не упомню уж.

--
Regards, LVT.

> Leonid Troyanovsky © (19.11.08 19:29) [29]

> AllocateWnd выделяет память честно - for execute.

В смысле MakeObjectInstance, или как его, sorry.

--
Regards, LVT.

Leonid Troyanovsky © (19.11.08 19:29) [29]
Вот, те кто реализовывал ок. проц. на стеке - тот пострадал.
Например я :) Я еще недоумевал, зачем они делают так сложно, когда можно хранить процедуру в самом объекте :)

Заюзать метод класса как WindowProc Найти похожие ветки