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

Вниз

Библиотека winlite   Найти похожие ветки 

← →
Vjacheslav   (2005-09-01 23:13) [0]

Не могу создать окно,точнее окно создается и сразу закрывается.
MYWnd:=TLiteWindow.Create(0);
Вот  часть содержания winlite.pas
unit WinLite;
interface
uses Windows, Messages;
type
 TWindowParams = record
   Caption: PChar;
   Style: DWord;
   ExStyle: DWord;
   X: Integer;
   Y: Integer;
   Width: Integer;
   Height: Integer;
   WndParent: THandle;
   WndMenu: THandle;
   Param: Pointer;
   WindowClass: TWndClass;
 end;
type
 TDialogParams = record
   Template: PChar;
   WndParent: THandle;
 end;

type
 TLiteFrame = class(TObject)
 private
   FWndCallback: Pointer;
   FWndHandle: THandle;
   FWndParent: THandle;
   function WindowCallback(hWnd: HWnd; Msg, WParam, LParam: Longint): Longint;
     stdcall;
 protected
   procedure WindowProcedure(var Msg: TMessage); virtual;
 public
   property WndHandle: THandle read FWndHandle;
   property WndCallback: Pointer read FWndCallback;
 public
   constructor Create(AWndParent: THandle); virtual;
   destructor Destroy; override;
 end;

type
 TLiteWindow = class(TLiteFrame)
 private
   FWndParams: TWindowParams;
   FWndSubclass: Pointer;
 protected
   procedure CreateWindowParams(var WindowParams: TWindowParams); virtual;
 public
   procedure DefaultHandler(var Msg); override;
   constructor Create(AWndParent: THandle); override;
   constructor CreateSubclassed(AWnd: THandle); virtual;
   destructor Destroy; override;
 end;

 implementation

constructor TLiteFrame.Create(AWndParent: THandle);
begin
 inherited Create;
 FWndParent := AWndParent;
 FWndCallback := VirtualAlloc(nil, 12, MEM_RESERVE or MEM_COMMIT,
   PAGE_EXECUTE_READWRITE);
 asm
   mov  EAX, Self
   mov  ECX, [EAX].TLiteFrame.FWndCallback
   mov  word  ptr [ECX+0], $6858
   mov  dword ptr [ECX+2], EAX  
   mov  word  ptr [ECX+6], $E950
   mov  EAX, OFFSET(TLiteFrame.WindowCallback)
   sub  EAX, ECX
   sub  EAX, 12
   mov  dword ptr [ECX+8], EAX  
end;
end;

destructor TLiteFrame.Destroy;
begin
 VirtualFree(FWndCallback, 0, MEM_RELEASE);
 inherited;
end;

function TLiteFrame.WindowCallback(hWnd: HWnd; Msg, WParam, LParam: Integer):
 Longint;
var
 WindowMsg: TMessage;
begin
 if FWndHandle = 0 then
   FWndHandle := hWnd;
 WindowMsg.Msg := Msg;
 WindowMsg.WParam := WParam;
 WindowMsg.LParam := LParam;
 WindowProcedure(WindowMsg);
 Result := WindowMsg.Result;
end;

procedure TLiteFrame.WindowProcedure(var Msg: TMessage);
begin
 Dispatch(Msg);
end;

constructor TLiteWindow.Create(AWndParent: THandle);
begin
 inherited;
 CreateWindowParams(FWndParams);
 RegisterClass(FWndParams.WindowClass);
 with FWndParams do
   CreateWindowEx(ExStyle, WindowClass.lpszClassName, Caption,
     Style, X, Y, Width, Height,
     WndParent, WndMenu, hInstance, Param);
end;

destructor TLiteWindow.Destroy;
begin
 if FWndSubclass = nil then
 begin
   UnregisterClass(FWndParams.WindowClass.lpszClassName, hInstance);
   if IsWindow(FWndHandle) then
     DestroyWindow(FWndHandle);
 end
 else
   SetWindowLong(FWndHandle, GWL_WNDPROC, DWord(FWndSubclass));
 inherited;
end;

procedure TLiteWindow.CreateWindowParams(var WindowParams: TWindowParams);
var
 WndClassName: string;
begin
 Str(DWord(Self), WndClassName);
 WndClassName := ClassName + ":" + WndClassName;
 with FWndParams.WindowClass do
 begin
   style := CS_DBLCLKS;
   lpfnWndProc := WndCallback;
   cbClsExtra := 0;
   cbWndExtra := 0;
   lpszClassName := PChar(WndClassName);
   hInstance := hInstance;
   hIcon := LoadIcon(0, IDI_APPLICATION);
   hCursor := LoadCursor(0, IDC_ARROW);
   hbrBackground := COLOR_BTNFACE + 1;
   lpszMenuName := "";
 end;

 with FWndParams do
 begin
   WndParent := FWndParent;
   Caption := "Lite Window";
   Style := WS_OVERLAPPEDWINDOW or WS_VISIBLE;
   ExStyle := 0;
   X := Integer(CW_USEDEFAULT);
   Y := Integer(CW_USEDEFAULT);
   Width := Integer(CW_USEDEFAULT);
   Height := Integer(CW_USEDEFAULT);
   WndMenu := 0;
   Param := nil;
 end;
end;

procedure TLiteWindow.DefaultHandler(var Msg);
begin
 if FWndSubclass = nil then
   with TMessage(Msg) do
     Result := DefWindowProc(FWndHandle, Msg, WParam, LParam)
 else
   with TMessage(Msg) do
     Result := CallWindowProc(FWndSubclass, FWndHandle, Msg, WParam, LParam);
end;



---

← →
Vjacheslav   (2005-09-02 01:58) [1]

Все разобрался.Просто надо дописать
while GetMessage(Msg, 0, 0, 0) do
 begin
   TranslateMessage(Msg);
   DispatchMessage(Msg);
 end;

---

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

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

Наверх

Память: 0.47 MB
Время: 0.04 c