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 mswindows}\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   twindowobjectbase=class(tobject)\r
  24     hwndmain:hwnd;\r
  25     onmsg:function(msg,wparam,lparam:taddrint):boolean of object;\r
  26     exitloopflag:boolean;\r
  27     exstyle,style:integer;\r
  28     docreatewindow:boolean;\r
  29     function windowprocaddr:pointer; virtual;\r
  30     procedure init_window(dwexstyle,dwstyle:cardinal);\r
  31     procedure init; virtual;\r
  32     procedure initinvisible;\r
  33     function settimer(id,timeout:taddrint):integer;\r
  34     function killtimer(id:taddrint):boolean;\r
  35     procedure postmessage(msg,wparam,lparam:taddrint);\r
  36     procedure messageloop;\r
  37     {$ifdef mswindows}\r
  38       procedure processmessages; virtual;\r
  39       function processmessage:boolean;\r
  40     {$endif}  \r
  41     constructor create; virtual;\r
  42     destructor destroy; override;\r
  43   end;\r
  44 \r
  45   {this type exists for compatibility with the original one in bewarehttpd,\r
  46   therefore it inits on create}\r
  47   twindowobject=class(twindowobjectbase)\r
  48     constructor create; override;\r
  49   end;\r
  50 \r
  51 function WindowProc_windowobjectbase(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
  52 \r
  53 var\r
  54   twindowobject_Class : TWndClass = (style:0; lpfnWndProc:nil;\r
  55   cbClsExtra:0; cbWndExtra:sizeof(pointer); hInstance:thinstance(0); hIcon:hicon(0); hCursor:hcursor(0);\r
  56   hbrBackground:hbrush(0);lpszMenuName:nil; lpszClassName:'twindowobject_class');\r
  57 \r
  58 \r
  59 implementation\r
  60 \r
  61 //uses safewriteln;\r
  62 \r
  63 {------------------------------------------------------------------------------}\r
  64 \r
  65 function WindowProc_windowobjectbase(ahWnd:HWND; auMsg:Integer; awParam:WPARAM; alParam:LPARAM):Integer; stdcall;\r
  66 var\r
  67   i:taddrint;\r
  68 begin\r
  69   ////swriteln('in unitwindowobject.windowproc');\r
  70   Result := 0;  // This means we handled the message\r
  71   if ahwnd <> hwnd(0) then i := getwindowlongptr(ahwnd,0) else i := 0;\r
  72   if i <> 0 then begin\r
  73     if assigned(twindowobjectbase(i).onmsg) then begin\r
  74       if not twindowobjectbase(i).onmsg(aumsg,awparam,alparam) then i := 0;\r
  75     end else i := 0\r
  76   end;\r
  77   if i = 0 then Result := DefWindowProc(ahWnd, auMsg, awParam, alParam)\r
  78 end;\r
  79 \r
  80 \r
  81 function twindowobjectbase.windowprocaddr;\r
  82 begin\r
  83   result := @WindowProc_windowobjectbase;\r
  84 end;\r
  85 \r
  86 procedure twindowobjectbase.initinvisible;\r
  87 begin\r
  88   init_window(WS_EX_TOOLWINDOW,WS_POPUP);\r
  89 end;\r
  90 \r
  91 procedure twindowobjectbase.init;\r
  92 begin\r
  93   //\r
  94 end;\r
  95 \r
  96 function twindowobjectbase.settimer;\r
  97 begin\r
  98   result := windows.settimer(hwndmain,id,timeout,nil);\r
  99 end;\r
 100 \r
 101 function twindowobjectbase.killtimer;\r
 102 begin\r
 103   result := windows.killtimer(hwndmain,id);\r
 104 end;\r
 105 \r
 106 \r
 107 \r
 108 procedure twindowobjectbase.init_window;\r
 109 begin\r
 110     //swriteln('in twindowobject.create, about to call registerclass');\r
 111   twindowobject_Class.lpfnWndProc := windowprocaddr;\r
 112   Windows.RegisterClass(twindowobject_Class);\r
 113   //swriteln('about to call createwindowex');\r
 114 \r
 115   style := dwstyle;\r
 116   exstyle := dwexstyle;\r
 117   hWndMain := CreateWindowEx(dwexstyle, twindowobject_Class.lpszClassName,\r
 118     '', dwstyle, CW_USEDEFAULT, CW_USEDEFAULT,100, 100, hwnd(0), 0, HInstance, nil);\r
 119   //swriteln('about to check result of createwindowex');\r
 120   if hWndMain = hwnd(0) then raise exception.create('CreateWindowEx failed');\r
 121   //swriteln('about to store reference to self in extra windo memory');\r
 122   setwindowlongptr(hwndmain,0,taddrint(self));\r
 123   //swriteln('finished twindowobject.create , hwndmain='+inttohex(taddrint(hwndmain),16));\r
 124 end;\r
 125 \r
 126 \r
 127 constructor twindowobjectbase.create;\r
 128 begin\r
 129   inherited;\r
 130 \r
 131 end;\r
 132 \r
 133 destructor twindowobjectbase.destroy;\r
 134 begin\r
 135   if hWndMain <> hwnd(0) then DestroyWindow(hwndmain);\r
 136   inherited;\r
 137 end;\r
 138 \r
 139 procedure twindowobjectbase.postmessage;\r
 140 begin\r
 141   windows.postmessage(hwndmain,msg,wparam,lparam);\r
 142 end;\r
 143 \r
 144 {$ifdef mswindows}\r
 145 function twindowobjectbase.ProcessMessage : Boolean;\r
 146 var\r
 147     MsgRec : TMsg;\r
 148 begin\r
 149     Result := FALSE;\r
 150     if PeekMessage(MsgRec, 0, 0, 0, PM_REMOVE) then begin\r
 151       Result := TRUE;\r
 152       TranslateMessage(MsgRec);\r
 153       DispatchMessage(MsgRec);\r
 154     end;\r
 155 end;\r
 156 \r
 157 procedure twindowobjectbase.processmessages;\r
 158 begin\r
 159   while processmessage do;\r
 160 end;\r
 161 {$endif}\r
 162 \r
 163 procedure twindowobjectbase.messageloop;\r
 164 var\r
 165   MsgRec : TMsg;\r
 166 begin\r
 167   while GetMessage(MsgRec, hwnd(0), 0, 0) do begin\r
 168     {$ifdef mswindowss}\r
 169     TranslateMessage(MsgRec);\r
 170     {$endif}\r
 171     DispatchMessage(MsgRec);\r
 172     if exitloopflag then exit;\r
 173     {if not peekmessage(msgrec,0,0,0,PM_NOREMOVE) then onidle}\r
 174   end;\r
 175 end;\r
 176 \r
 177 \r
 178 {------------------------------------------------------------------------------}\r
 179 \r
 180 constructor twindowobject.create;\r
 181 begin\r
 182   inherited;\r
 183   initinvisible;\r
 184 end;\r
 185 \r
 186 {------------------------------------------------------------------------------}\r
 187 \r
 188 \r
 189 end.\r