/[lcore]/trunk/unitwindowobject.pas
ViewVC logotype

Contents of /trunk/unitwindowobject.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 149 - (show annotations)
Sun Sep 10 20:02:13 2017 UTC (3 months ago) by plugwash
File size: 5149 byte(s)
Replace obsolete/broken lcoregtklaz with new lcorelazarus
Rename lmessages to lcoremessages due to unit name conflict with Lazarus

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

Properties

Name Value
svn:eol-style CRLF

No admin address has been configured">No admin address has been configured
ViewVC Help
Powered by ViewVC 1.1.5