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

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

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


Страницы:   1 2

SpellCaster ©   (2008-03-26 13:47:00) 

Возникла такая надобность: создать окошко для приёма сообщений для каждого экземпляра класса. По определённым причинам пользоваться 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 17:03:00) [21]

> [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 по дефолту), вот окно и удалялось

DVM   (2008-03-26 16:50:00) [22]


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

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

guav   (2008-03-26 16:38:00) [23]

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

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

DVM   (2008-03-26 16:22:00) [24]

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

DVM   (2008-03-26 16:21:00) [25]

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:20:00) [26]

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;

Игорь Шевченко   (2008-03-26 15:35:00) [27]


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


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

guav   (2008-03-26 14:47:00) [28]

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

Reindeer Moss Eater   (2008-03-26 14:19:00) [29]

AllocateHWnd

Игорь Шевченко   (2008-03-26 14:13:00) [30]

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

 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;

SpellCaster   (2008-03-26 13:52:00) [31]

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

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;

Страницы:   1 2

Наверх

Титульная страница Поиск, карта сайта Написать письмо