unitwindowobject.pas

   1 { Copyright (C) 2005 Bas Steendijk and Peter Green\r
   2   For conditions of distribution and use, see copyright notice in zlib_license.txt\r
   3   which is included in the package\r
   4   ----------------------------------------------------------------------------- }\r
   5 \r
   6 unit unitwindowobject;\r
   7 \r
   8 interface\r
   9 \r
  10 uses\r
  11   classes,\r
  12   {$ifdef win32}\r
  13     windows,messages,wmessages,\r
  14   {$else}\r
  15     lmessages,\r
  16     {$macro on}\r
  17     {$define windows := lmessages}\r
  18   {$endif}\r
  19   sysutils,\r
  20   pgtypes;\r
  21 \r
  22 type\r
  23   twindowobject=class(tobject)\r
  24     hwndmain:hwnd;\r
  25     onmsg:function(msg,wparam,lparam:taddrint):boolean of object;\r
  26     exitloopflag:boolean;\r
  27     function settimer(id,timeout:taddrint):integer;\r
  28     function killtimer(id:taddrint):boolean;\r
  29     procedure postmessage(msg,wparam,lparam:taddrint);\r
  30     procedure messageloop;\r
  31     {$ifdef win32}\r
  32       procedure processmessages;\r
  33       function processmessage:boolean;\r
  34     {$endif}\r
  35     constructor create;\r
  36     destructor destroy; override;\r
  37   end;\r
  38 \r
  39 implementation\r
  40 \r
  41 //uses safewriteln;\r
  42 \r
  43 function WindowProc(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
  44 var\r
  45   i:taddrint;\r
  46 begin\r
  47   ////swriteln('in unitwindowobject.windowproc');\r
  48   Result := 0;  // This means we handled the message\r
  49   if ahwnd <> hwnd(0) then i := getwindowlongptr(ahwnd,0) else i := 0;\r
  50   if i <> 0 then begin\r
  51     if assigned(twindowobject(i).onmsg) then begin\r
  52       if not twindowobject(i).onmsg(aumsg,awparam,alparam) then i := 0;\r
  53     end else i := 0\r
  54   end;\r
  55   if i = 0 then Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
  56 end;\r
  57 \r
  58 var\r
  59   twindowobject_Class : TWndClass = (style:0; lpfnWndProc:@WindowProc;\r
  60   cbClsExtra:0; cbWndExtra:sizeof(pointer); hInstance:thinstance(0); hIcon:hicon(0); hCursor:hcursor(0);\r
  61   hbrBackground:hbrush(0);lpszMenuName:nil; lpszClassName:'twindowobject_class');\r
  62 \r
  63 function twindowobject.settimer;\r
  64 begin\r
  65   result := windows.settimer(hwndmain,id,timeout,nil);\r
  66 end;\r
  67 \r
  68 function twindowobject.killtimer;\r
  69 begin\r
  70   result := windows.killtimer(hwndmain,id);\r
  71 end;\r
  72 \r
  73 constructor twindowobject.create;\r
  74 begin\r
  75   inherited;\r
  76   //swriteln('in twindowobject.create, about to call registerclass');\r
  77   Windows.RegisterClass(twindowobject_Class);\r
  78   //swriteln('about to call createwindowex');\r
  79   hWndMain := CreateWindowEx(WS_EX_TOOLWINDOW, twindowobject_Class.lpszClassName,\r
  80     '', WS_POPUP, 0, 0,0, 0, hwnd(0), 0, HInstance, nil);\r
  81   //swriteln('about to check result of createwindowex');\r
  82   if hWndMain = hwnd(0) then raise exception.create('CreateWindowEx failed');\r
  83   //swriteln('about to store reference to self in extra windo memory');\r
  84   setwindowlongptr(hwndmain,0,taddrint(self));\r
  85   //swriteln('finished twindowobject.create , hwndmain='+inttohex(taddrint(hwndmain),16));\r
  86 end;\r
  87 \r
  88 destructor twindowobject.destroy;\r
  89 begin\r
  90   if hWndMain <> hwnd(0) then DestroyWindow(hwndmain);\r
  91   inherited;\r
  92 end;\r
  93 \r
  94 procedure twindowobject.postmessage;\r
  95 begin\r
  96   windows.postmessage(hwndmain,msg,wparam,lparam);\r
  97 end;\r
  98 \r
  99 {$ifdef win32}\r
 100   function twindowobject.ProcessMessage : Boolean;\r
 101   var\r
 102     Msg : TMsg;\r
 103   begin\r
 104     Result := FALSE;\r
 105     if PeekMessage(Msg, hwndmain, 0, 0, PM_REMOVE) then begin\r
 106       Result := TRUE;\r
 107       DispatchMessage(Msg);\r
 108     end;\r
 109   end;\r
 110 \r
 111   procedure twindowobject.processmessages;\r
 112   begin\r
 113     while processmessage do;\r
 114   end;\r
 115 {$endif}\r
 116 \r
 117 procedure twindowobject.messageloop;\r
 118 var\r
 119   MsgRec : TMsg;\r
 120 begin\r
 121   while GetMessage(MsgRec, hwnd(0), 0, 0) do begin\r
 122     DispatchMessage(MsgRec);\r
 123     if exitloopflag then exit;\r
 124     {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}\r
 125   end;\r
 126 end;\r
 127 \r
 128 end.\r