Мастера DELPHI, Delphi programming community Рейтинг@Mail.ru Титульная страница Поиск, карта сайта Написать письмо 
| Новости |
Новости сайта
Поиск |
Поиск по лучшим сайтам о Delphi
FAQ |
Огромная база часто задаваемых вопросов и, конечно же, ответы к ним ;)
Статьи |
Подборка статей на самые разные темы. Все о DELPHI
Книги |
Новинки книжного рынка
Новости VCL
Обзор свежих компонент со всего мира, по-русски!
|
| Форумы
Здесь вы можете задать свой вопрос и наверняка получите ответ
| ЧАТ |
Место для общения :)
Орешник |
Коллекция курьезных вопросов из форумов
KOL и MCK |
KOL и MCK - Компактные программы на Delphi
Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / rsdn.org

 
Чтобы не потерять эту дискуссию, сделайте закладку « предыдущая ветвь | форум | следующая ветвь »
Страницы: 1 2 3 4

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


dmk ©   (21.03.17 22:54

У меня есть такой вариант, но он работает только вне класса:

function ClientWindowProc(wnd: HWND; msg: cardinal; wparam, lparam: integer): integer; stdcall;
var
 P: pointer;
 Style: dword;
 ExStyle: dword;

begin
 P := Pointer(GetWindowLong(wnd, GWL_USERDATA));

 case msg of
 WM_NCCALCSIZE:
 begin
   Style := GetWindowLong(wnd, GWL_STYLE);
   ExStyle := GetWindowLong(wnd, GWL_EXSTYLE);

   //Убираем скроллы MDI-окна
   if (Style and (WS_HSCROLL or WS_VSCROLL)) <> 0 then
   begin
     Style := Style and not (WS_HSCROLL or WS_VSCROLL);
     SetWindowLong(wnd, GWL_STYLE, Style);
   end;

   //Убираем выступ в клиентской области MDI-окна
   if (ExStyle and (WS_EX_CLIENTEDGE)) <> 0 then
   begin
     ExStyle := (ExStyle and not WS_EX_CLIENTEDGE);
     SetWindowLong(wnd, GWL_EXSTYLE, ExStyle);
   end;

   Result := S_OK;
 end;//WM_NCCALCSIZE
 end;//case

 Result := CallWindowProc(P, Wnd, Msg, WParam, LParam);
end;

//................................................................................ ......................................

procedure InitClientProc(ClientHandle: integer);
begin
 if (ClientHandle <> 0) then
 begin
   //Данные пользователя могут быть заняты
   if GetWindowLongPtr(ClientHandle, GWL_USERDATA) = 0 then
   begin
     SetWindowLongPtr(ClientHandle, GWL_USERDATA,
       SetWindowLongPtr(ClientHandle, GWL_WNDPROC, NativeUInt(@ClientWindowProc)));
   end;
 end;
end;


dmk ©   (21.03.17 23:17[1]

Мне нужно принимать сообщение от родительского окна в безоконный класс.


dmk ©   (21.03.17 23:18[2]

В гугле полно примеров, но все нерабочие.


dmk ©   (22.03.17 02:13[3]

Делаю так:

type TCallWndProc = function(Wnd: HWND; Msg: cardinal; WParam, LParam: integer): integer of object; stdcall;

//в классе
 FCallWndProc: TCallWndProc;

function TWindow64.ClientWindowProc(wnd: HWND; msg: cardinal; wparam, lparam: integer): integer; stdcall;
var
P: pointer;
Style: dword;
ExStyle: dword;

begin
P := Pointer(GetWindowLong(wnd, GWL_USERDATA));

case msg of
WM_NCCALCSIZE:
begin
  Style := GetWindowLong(wnd, GWL_STYLE);
  ExStyle := GetWindowLong(wnd, GWL_EXSTYLE);

  //Убираем скроллы MDI-окна
  if (Style and (WS_HSCROLL or WS_VSCROLL)) <> 0 then
  begin
    Style := Style and not (WS_HSCROLL or WS_VSCROLL);
    SetWindowLong(wnd, GWL_STYLE, Style);
  end;

  //Убираем выступ в клиентской области MDI-окна
  if (ExStyle and (WS_EX_CLIENTEDGE)) <> 0 then
  begin
    ExStyle := (ExStyle and not WS_EX_CLIENTEDGE);
    SetWindowLong(wnd, GWL_EXSTYLE, ExStyle);
  end;

  Result := S_OK;
end;//WM_NCCALCSIZE
end;//case

Result := CallWindowProc(P, Wnd, Msg, WParam, LParam);
end;

procedure TWindow64.InitClientWndProc(AHandle: integer);
var
 L: NativeInt;

begin
 if (AHandle <> 0) then
 begin
   //Данные пользователя могут быть заняты
   if GetWindowLongPtr(AHandle, GWL_USERDATA) = 0 then
   begin
     FCallWndProc := ClientWndProc;
     L := SetWindowLongPtr(AHandle, GWL_WNDPROC, NativeUInt(@FCallWndProc));
     L := SetWindowLongPtr(AHandle, GWL_USERDATA, L);
   end;
 end;
end;


Проходит один цикл и виснет.
Если не делать частью класса - все в порядке, но переменные класса не видны.
Можно сделать вызов, если ClientWindowProc часть класса?


Leonid Troyanovsky ©   (22.03.17 08:47[4]


> dmk ©   (22.03.17 02:13) [3]

В 32 битные времена этому служил MakeObjectInstance.

--
Regards, LVT.


Игорь Шевченко ©   (22.03.17 10:48[5]

Ты по человечески можешь сказать, что тебе надо ? Существует масса способов решения самых разнообразных задач


dmk ©   (22.03.17 13:15[6]

>Ты по человечески можешь сказать, что тебе надо ?
У меня есть класс графических объектов, которые рисуются в буфере, а потом выводятся на экран. Мне надо им петлю сообщений вставить. Чтобы они WM_MOUSE..... получали. Вроде как компоненты, но окна они не имеют. Можно конечно из базового окна им передавать координаты, но есть недотаток, это можно сделать только между WM_PAINT, а отрисовка по WM_PAINT иногда сильно тормозит (когда их много) и мне надо прервать отрисовку и начать заново. Насколько я знаю сообщения передаются асинхронно и это то что мне надо.


dmk ©   (22.03.17 13:19[7]

>В 32 битные времена этому служил MakeObjectInstance.
Это немного не то. Механизм вызова я подсмотрел, но уверенности нет. Вроде как правильный адрес он в стеке хранит.
Там:
 pop ecx, а потом call farptr идет.

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


NoUser ©   (22.03.17 14:05[8]


> Это немного не то.

И на сколько немного там это не то? ))

 private
   FOldWndProc  : IntPtr;
   FOldUserData : IntPtr;
   procedure InitClientWndProc(AHandle: HWND); // AHandle: integer ?
// function  ClientWindowProc(wnd: HWND; Msg: cardinal; wparam, lparam: integer): integer; stdcall;  // on x64??
   function  ClientWindowProc(Wnd: HWND; Msg: NativeInt ; wParam: NativeUInt; lParam: NativeInt): NativeInt; stdcall;
   class function DumMyWndProc(Wnd: HWND; Msg: NativeInt ; wParam: NativeUInt; lParam: NativeInt): NativeInt; static; stdcall;

procedure TWindow64.InitClientWndProc(AHandle: HWND);
begin
 //Данные пользователя могут быть заняты  // -> печалька
 //
 FOldWndProc := SetWindowLongPtr(AHandle, GWL_WNDPROC, IntPtr(@DummyWndProc));
 FOldUserData :=  SetWindowLongPtr(AHandle, GWL_USERDATA, IntPtr(Self));
end;

class function TWindow64.DumMyWndProc(Wnd: HWND; Msg: NativeInt; wParam: NativeUInt;lParam: NativeInt): NativeInt;
var
Tmp : Pointer;
begin
Tmp := Pointer(GetWindowLongPtr(Wnd, GWL_USERDATA));
if (Tmp <> nil) then                                                          // а вдруг там мышь ?,!
 try                                                                          
  Result := TWindow64(Tmp).ClientWindowProc(Wnd, Msg ,wParam, lParam);
 except end
else Result := DefWindowProc(Wnd, Msg ,wParam, lParam)                        // грустная печальная печалька
end;

function TWindow64.ClientWindowProc(Wnd: HWND; Msg: NativeInt; wParam: NativeUInt; lParam: NativeInt): NativeInt;
begin
// ...

SetWindowLongPtr(Wnd, GWL_USERDATA, IntPtr(FOldUserData));                    // печалька ->

Result := CallWindowProc(Pointer(FOldWndProc), Wnd, Msg, wParam, lParam);     // !

if IntPtr(@DumMyWndProc) <> GetWindowLongPtr(Wnd, GWL_WNDPROC) then           // печальная печалька
  FOldWndProc := SetWindowLongPtr(Wnd, GWL_WNDPROC, IntPtr(@DumMyWndProc));   // ::

FOldUserData := SetWindowLongPtr(Wnd, GWL_USERDATA, IntPtr(Self));            // печалька <-
end;


dmk ©   (22.03.17 15:00[9]

NoUser ©   (22.03.17 14:05) [8]
У меня нет окна. С окном все просто и без проблем.
А без окна GetLastError выдает InvalideDC


dmk ©   (22.03.17 15:08[10]

Windows не дает определить WndProc без окна. Можно только невидимое окно сделать.
Этот вопрос в соседней ветке.
А TWindow64 у меня класс от TObject. Там почти ничего нет. Мне просто нужен цикл сообщений. Делал через TNotifyEvent — такой вариант не подходит.


rrrrr ©   (22.03.17 15:55[11]

аллокейташвнд


dmk ©   (22.03.17 16:32[12]

>аллокейташвнд
Без окна не работает.
HWND создает, но при инсталляции GWL_USERDATA - GetLastError - Invalid DC.
Может на семерке работает, а на 10-ке точно не работает. Все примеры из гугла не рабочие :(


rrrrr ©   (22.03.17 16:36[13]

type
TMyStupidClass = class(TObject)
 fWnd : HWND;
 constructor createIt();
 procedure onMessage(var Message: TMessage);
 property handle : HWND read fWnd;
end;

constructor TMyStupidClass.createIt;
begin
inherited create();
fWnd := AllocateHWnd(onMessage);
end;

procedure TMyStupidClass.onMessage(var Message: TMessage);
begin
form1.Caption := IntToStr(Message.Msg);
end;

procedure TForm1.FormCreate(Sender: TObject);
var stc : TMyStupidClass;
begin
stc := TMyStupidClass.createIt();
PostMessage(stc.handle,WM_USER + 1000, 0,0);
end;


dmk ©   (22.03.17 17:44[14]

rrrrr ©   (22.03.17 16:36) [13]
Мне от системы надо!!! :) WM_MOUSEMOVE
Оно только с окном приходит.
Не выходит каменный цветок.


rrrrr ©   (22.03.17 17:57[15]

Мне нужно принимать сообщение от родительского окна в безоконный класс.

родительское окно - настоящее.
безоконный класс принимать сообщения может.
транслируй!


dmk ©   (22.03.17 18:00[16]

>транслируй!
Уже


rrrrr ©   (22.03.17 18:01[17]

procedure TMyStupidClass.onMessage(var Message: TMessage);
begin
form1.Caption := Format('mouse coords: %d %d',[Message.WParam, Message.LParam]);
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
PostMessage(stc.handle, WM_MOUSEMOVE, Y,X);
end;


rrrrr ©   (22.03.17 18:04[18]

только зачем все это, если можно прямо методы дергать


NoUser ©   (22.03.17 18:25[19]

> dmk ©   (22.03.17 15:00) [9]
> У меня нет окна.

Сочувствую, а как же :

> dmk ©   (22.03.17 02:13) [3]
> Если не делать частью класса - все в порядке, но переменные класса не видны.


> rrrrr ©   (22.03.17 18:04) [18]
!


Страницы: 1 2 3 4 версия для печати

Написать ответ

Ваше имя (регистрация  E-mail 







Разрешается использование тегов форматирования текста:
<b>жирный</b> <i>наклонный</i> <u>подчеркнутый</u>,
а для выделения текста программ, используйте <code> ... </code>
и не забывайте закрывать теги! </b></i></u></code> :)


Наверх

  Рейтинг@Mail.ru     Титульная страница Поиск, карта сайта Написать письмо