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

Вниз

Заюзать метод класса как 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 подменяют, прошу прощения.

---

← →
han_malign ©   (2008-03-27 13:20) [25]

> Уж сколько раз твердили миру:
>
>  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;
- потому как не исключено, что это дело нацеливалось на копирование пользовательских данных... скорее всего, конечно, для валидации, но если в очередном сервис-паке Висты все нагнется - я сильно не удивлюсь.

---

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

han_malign ©   (27.03.08 13:20) [25]

Не, оно не копируется. Внутре указатель передается.

---

← →
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);

---

← →
Leonid Troyanovsky ©   (2008-11-19 19:20) [28]

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

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

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

--
Regards, LVT.

---

← →
Leonid Troyanovsky ©   (2008-11-19 19:29) [29]

> SpellCaster   (26.03.08 17:03) [11]

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

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

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

--
Regards, LVT.

---

← →
Leonid Troyanovsky ©   (2008-11-19 19:36) [30]

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

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

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

--
Regards, LVT.

---

← →
GrayFace ©   (2008-11-23 04:08) [31]

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

---

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

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

Наверх

Память: 0.56 MB
Время: 0.016 c