Макет TAppAPI

← →
Sphinx (2005-01-05 15:23) [0]

type TAppEngine = class private FAppName: PChar; FAppTitle: PChar; FAppHandle: THandle; FScreenWidth: Word; FScreenHeight: Word; FAppActive: Boolean; FAppRun: Boolean; function FWinCreate: HResult; procedure WMButtonDown (var aMsg: TMessage); message WM_KEYDOWN; protected published public property Active: Boolean read FAppActive; property Run: Boolean read FAppRun; constructor Create(AppName, AppTitle: PChar; ScreenWidth, ScreenHeight: Word); destructor Destroy; override; function GetHandle: THandle; end; function WindowProc(iHandle: THandle; aMSG: Cardinal; wParam: Cardinal; lParam: Integer): Integer; stdcall; begin Result := DefWindowProc(iHandle, aMSG, wParam, lParam); end; constructor TAppEngine.Create(AppName, AppTitle: PChar; ScreenWidth, ScreenHeight: Word); begin FAppRun:=False; FAppActive:=False; if (AppName="") or (AppTitle="") then Exit; FAppName:=AppName; FAppTitle:=AppTitle; FScreenWidth:=ScreenWidth; FScreenHeight:=ScreenHeight; if FWinCreate<>S_OK then Exit; FAppRun:=True; inherited Create; end; function TAppEngine.FWinCreate: HRESULT; var // ñòðóêòóðà îïèñûâàþùàÿ ïàðàìåòðû ñîçäàâàåìîãî ìåíþ WinClass: TWndClass; Instance: HWnd; begin // îïðåäåëåíèå ïàðàìåòðîâ ñîçäàâàåìîãî îêíà Instance:=HInstance; // îïðåäåëåíèå êëàññà WinClass.lpszClassName:=FAppName; // óêàçàíèå ïðîöåäóðû äëÿ îáðàáîòêè ïðèõîäÿùèé ñîáûòèé WinClass.lpfnWndProc:=@WindowProc; // ñòèëü îêíà WinClass.style:=CS_VREDRAW or CS_HREDRAW; // óêàçàòåëü ìîäóëÿ WinClass.hInstance:=Instance; // èêîíêà ïðèëîæåíèÿ WinClass.hIcon:=LoadIcon(Instance, MakeIntResource("ICON")); // êóðñîð ïðèëîæåíèÿ WinClass.hCursor:=LoadCursor(0, IDC_ARROW); // ôîíîâûé öâåò îêíà WinClass.hbrBackground:=($000000); // äîïîëíèòåëüíûå ïàðàìåòðû íå íóæíûå â äàííîì ïðèëîæåíèè WinClass.lpszMenuName:=nil; WinClass.cbClsExtra:=0; WinClass.cbWndExtra:=0; // ïîïûòêà çàðåãåñòðèðîâàòü êëàññ ïðèëîæåíèÿ if (RegisterClass(WinClass)=0) then begin // ðåãèñòðàöèÿ ïðîâàëåíà, Result:=E_FAIL; Exit; end; // ñîçäàíèå îêíà ïðîãðàììû FAppHandle := CreateWindowEx (WS_EX_APPWINDOW , // ðàñøèðåííûé ñòèëü îêíà FAppName, // èìÿ êëàññà FAppTitle, // çàãîëîâîê îêíà WS_POPUP, // ñòèëü îêíà 0, // ëåâàÿ ïîçèöèÿ îêíà 0, // ïðàâàÿ ïîçèöèÿ îêíà FScreenWidth, // øèðèíà îêíà FScreenHeight, // âûñîòà îêíà 0, // îòíîøåíèå ê ãëàâíîìó îêíó // 0-ãëàâíîå îêíî 0, // ìåíþ ïðèëîæåíèÿ Instance, // óêàçàòåëü ìîäóëÿ nil ); // ïàðàìåòðû îêíà // åñëè íå óäàëîñü ñîçäàòü îêíî if (FAppHandle = 0) then begin Result := E_FAIL; Exit; end; // ïîêàçàòü îêíî ShowWindow(FAppHandle, SW_SHOW); // ïåðåêëþ÷åíèå àêòèâíîãî îêíà SetActiveWindow(FAppHandle); // ïðîðèñîâàòü ñîäåðæèìîå îêíà UpdateWindow(FAppHandle); // ïðîöåäóðà çàâåðøåíà óñïåøíî Result := S_OK; end; procedure TAppEngine.WMButtonDown (var aMsg: TMessage); begin if INT(aMsg.WParam)=VK_F12 then FAppRun:=False; end;

и в проекте:

App:=TAppEngine.Create("D3DEngine", "DirectX D3D Engine", 800, 600); mainHandle:=App.GetHandle; // áåñêîíå÷íûé öèêë while App.Run do begin PeekMessage(aMSG, mainHandle, 0, 0, PM_REMOVE); TranslateMessage(aMsg); DispatchMessage(aMsg); end; if Assigned(App) then App.Free;

Проблема в том что при нажатии F12 окно не закрывается, то есть TAppEngine.WMButtonDown судя по всему не выполняется...

← →
Sphinx (2005-01-05 15:24) [1]

Ой...звиняюсь...коментарии на русском были...

З.Ы. Заранее благодарен за помощ

← →
GuAV © (2005-01-05 15:54) [2]

А какие меры вообще приняты для того чтоб сообщение передавалось классу TAppEngine ?

Выход из цикла должен бы быть по wm_quit.

>function WindowProc(iHandle: THandle; aMSG: Cardinal;
> wParam: Cardinal; lParam: Integer): Integer; stdcall;
>begin
> Result := DefWindowProc(iHandle, aMSG, wParam,
>lParam);
> end;

Если это готовая оконная процедура, то смысл не ясен.

← →
Sphinx (2005-01-05 17:23) [3]

Я только разбираюсь в WinAPI, до этого все сообщения обрабатывал в WindowProc, и не создавал ни какого класса, но копировать код создания и обработки событий из одного проекта в другой надоело. Поэтому и пытаюсь создать класс для WinAPI. Самый простой.

> А какие меры вообще приняты для того чтоб сообщение передавалось
> классу TAppEngine ?

> procedure WMButtonDown (var aMsg: TMessage); message WM_KEYDOWN;

Это не передает сообщения??? Прочитал что вроде это как раз прием сообщений от Windows программой, или это только если создан объект Application из Forms?

← →
GuAV © (2005-01-05 18:12) [4]

Sphinx (05.01.05 17:23) [3]
Это не передает сообщения???

Это принимает сообщение. См controls.pas начиная отсюда: FObjectInstance := Classes.MakeObjectInstance(MainWndProc);

← →
Sphinx (2005-01-06 23:13) [5]

Я видимо чего-то недопонимаю, если трудно объясните.

Просмотрел controls.pas там во-первых
WinClass.lpfnWndProc:=@WindowProc;
ссылается на DefWindowProc из user32 и вобщем то отличай не очень много (как мне показалось)...только реализовано все через дополнительные классы и структуры...
Далее, почти все события определены в classes.pas примерно так же как и пытаюсь сделать я:

> procedure TAppEngine.WMButtonDown (var aMsg: TMessage);
только вместо aMsg: TMessage там для событий клавиатуры Msg: TWMKeyDown.

По поводу WM_QUIT - так не до него еще...не могу принять ни одно сообщение.

Интересно что если сделать так:
function WindowProc(iHandle: THandle; aMSG: Cardinal; wParam: Cardinal; lParam: Integer): Integer; stdcall; begin if (aMsg=WM_KEYDOWN) and (INT(wParam)=VK_F12) then Halt(0) Result := DefWindowProc(iHandle, aMSG, wParam, lParam); end; WinClass.lpfnWndProc:=@WindowProc;

то приложение закрывается...

а если описать:

procedure WMButtonDown (var aMsg: TMessage); message WM_KEYDOWN; procedure TAppEngine.WMButtonDown (var aMsg: TMessage); begin if INT(aMsg.WParam)=VK_F12 then Halt(0); end;

не закрывается, вот этого я не пойму, ведь если написано message WM_KEYDOWN то процедура должна выполнятся при поступлении сообщения о нажатии клавиши, или нет?

← →
GuAV © (2005-01-07 00:07) [6]

>Просмотрел controls.pas там во-первых
> WinClass.lpfnWndProc:=@WindowProc;

у меня там InitWndProc (D7)

Но она потом подменяется на FObjectInstance - результат MakeObjectInstance(MainWndProc);
из TWinControl.MainWndProc вызывается TControl.WindowProc, которая вызывает TWinControl.WndProc, она вызывает унаследованную TControl.WndProc. TControl.WndProc вызывает метод Dispatch, тем самым передавая сообщения обработчикам объекта.

Т.е. чтобы обработчик заработал нужно
0. написать оконный метод типа TWndMethod.
1. Сделать MakeObjectInstance для оконного метода.
2. Вызывать Dispatch из этого метода.

Возможно, можно совместить эти пункты, приведя Dispatch к TWndMethod.

Чтобы освободить память занятую под оконную процедуру MakeObjectInstance - вызвать FreeObjectInstance.

Да, забыл ещё
3. Указать результат MakeObjectInstance как оконную процедуру окна.

← →
Sphinx (2005-01-08 23:13) [8]

Провозился с исходниками VCL и RTL, вроде разобрался в хитросплетении вызовов между TControl и TWinControl.

Получилось следующее (переписал почти полностью, от греха подальше, благо еще не многое сделано):
unit uTWinAPI; interface uses Classes, Messages, SysUtils, Windows; type TWinAPI = class private FAppClass: PChar; FAppName: PChar; FAppHandle: THandle; FAppActive: Boolean; FAppRun: Boolean; FWindowLeft: Word; FWindowTop: Word; FWindowWidth: Word; FWindowHeight: Word; FWinClass: TWndClass; FWindowProc: TWndMethod; FObjectInstance: Pointer; procedure WMButtonDown (var aMsg: TMessage); message WM_KEYDOWN; protected published public constructor Create; destructor Destroy; override; property Handle: THandle read FAppHandle write FAppHandle; property Active: Boolean read FAppActive; property Run: Boolean read FAppRun; property WindowProc: TWndMethod read FWindowProc write FWindowProc; procedure WndProc(var aMessage: TMessage); function ShowDialog(Title, Text: PChar; uType: Cardinal): Integer; function WindowCreate(AppClass, AppName: PChar; Left, Top, Width, Height: Word): HResult; function WindowClose: HResult; end; implementation constructor TWinAPI.Create; begin FAppClass:="TWinAPI"; FAppName:="WinAPI1"; FAppActive:=False; FAppRun:=False; FWindowLeft:=0; FWindowTop:=0; FWindowWidth:=250; FWindowHeight:=150; FWindowProc:=WndProc; FObjectInstance:=Classes.MakeObjectInstance(WindowProc); inherited Create; end; destructor TWinAPI.Destroy; begin if FAppHandle<>0 then WindowClose; Classes.FreeObjectInstance(FObjectInstance); inherited Destroy; end; procedure TWinAPI.WndProc(var aMessage: TMessage); begin Dispatch(aMessage); // DefWindowProc(FAppHandle, aMessage.Msg, aMessage.WParam, aMessage.LParam); end; function TWinAPI.ShowDialog(Title, Text: PChar; uType: Cardinal): Integer; begin Result:=MessageBox(FAppHandle, Text, Title, uType); end; function TWinAPI.WindowCreate(AppClass, AppName: PChar; Left, Top, Width, Height: Word): HResult; var wordError: Word; cardinalError: Cardinal; begin Result:=E_Fail; if FAppHandle<>0 then begin Result:=S_False; Exit; end; if AppClass<>FAppClass then FAppClass:=AppClass; if AppName<>FAppName then FAppName:=AppName; if Left<>FWindowLeft then FWindowLeft:=Left; if Top<>FWindowTop then FWindowTop:=Top; if Width<>FWindowWidth then FWindowWidth:=Width; if Height<>FWindowHeight then FWindowHeight:=Height; FWinClass.lpszClassName:=FAppClass; FWinClass.lpfnWndProc:=FObjectInstance; FWinClass.style:=CS_VREDRAW or CS_HREDRAW; FWinClass.hInstance:=hInstance; FWinClass.hIcon:=LoadIcon(hInstance, MakeIntResource("ICON")); FWinClass.hCursor:=LoadCursor(0, IDC_ARROW); FWinClass.hbrBackground:=($000000); FWinClass.lpszMenuName:=nil; FWinClass.cbClsExtra:=0; FWinClass.cbWndExtra:=0; wordError:=Windows.RegisterClass(FWinClass); if wordError=0 then begin cardinalError:=GetLastError; ShowDialog(FAppName, PChar("RegisterClass"+#13#10+"Error № "+IntToStr(cardinalError)), mb_OK or mb_IconError); Exit; end; FAppHandle := CreateWindowEx (WS_EX_APPWINDOW, FAppClass, FAppName, WS_POPUP, FWindowLeft, FWindowTop, FWindowWidth, FWindowHeight, 0, 0, hInstance, nil ); if FAppHandle=0 then begin cardinalError:=GetLastError; ShowDialog(FAppName, PChar("CreateWindowEx"+#13#10+"Error № "+IntToStr(cardinalError)), mb_OK or mb_IconError); Exit; end; ShowWindow(FAppHandle, SW_SHOW); SetActiveWindow(FAppHandle); UpdateWindow(FAppHandle); FAppRun:=True; Result:=S_Ok; end; function TWinAPI.WindowClose; var longboolResult: LongBool; cardinalError: Cardinal; begin Result:=E_Fail; longboolResult:=DestroyWindow(FAppHandle); if longboolResult=False then begin cardinalError:=GetLastError; ShowDialog(FAppName, PChar("DestroyWindow"+#13#10+"Error № "+IntToStr(cardinalError)), mb_OK or mb_IconError); Exit; end; longboolResult:=Windows.UnregisterClass(FAppName, HInstance); if longboolResult=False then begin cardinalError:=GetLastError; ShowDialog(FAppName, PChar("UnregisterClass"+#13#10+"Error № "+IntToStr(cardinalError)), mb_OK or mb_IconError); Exit; end; FAppHandle:=0; FAppActive:=False; FAppRun:=False; end; procedure TWinAPI.WMButtonDown(var aMsg: TMessage); begin if INT(aMsg.WParam)=VK_F12 then begin WindowClose; end; end; end.

проект теперь выглядит следующим образом:

program Tester; {$R *.res} uses Windows, uTWinAPI in "uTWinAPI.pas"; var App: TWinAPI; mainHandle: THandle; aMsg: MSG; begin App:=TWinAPI.Create; App.WindowCreate("TWinAPI", "WinAPI1", 0, 0, 250, 150); mainHandle:=App.Handle; while App.Run do begin PeekMessage(aMSG, mainHandle, 0, 0, PM_REMOVE); TranslateMessage(aMsg); DispatchMessage(aMsg); end; App.WindowClose; App.Free; end.

При выполнении программа поставила меня в тупик, выпадает диалоговое окно:
CreateWindowEx
Error № 0 (NO_ERROR = без ошибок ?!)

а потом

DestroyWindow
Error № 1400 (ERROR_INVALID_WINDOW_HANDLE = оно и понятно, возвращается FAppHandle=0 ?!)

Заметил что ошибка пропадает если в качестве оконной процедуры указать к примеру @DefWindowProc или любую другую

процедуру вида:
procedure WProc(...)
даже указание такой процедуры procedure TWinAPI.WProc(...) приводит к такому же результату

и еще, если снять коментарий со строки DefWindowProc(FAppHandle, aMessage.Msg, aMessage.WParam, aMessage.LParam); то при запуске получаю:
CreateWindowEx
Error № 1400

Это я как понял происходит потому что при создании окна ему отсылаются сообщения, а FAppHandle еще не получен.

← →
Sphinx (2005-01-11 01:51) [9]

Макет TAppAPI Найти похожие ветки