source: cprs/trunk/CPRS-Chart/uFormMonitor.pas@ 1742

Last change on this file since 1742 was 1679, checked in by healthsevak, 10 years ago

Updating the working copy to CPRS version 28

File size: 15.3 KB
Line 
1unit uFormMonitor;
2
3interface
4
5uses
6 SysUtils, Forms, Classes, Windows, Messages, ExtCtrls, Contnrs, DateUtils;
7
8procedure SetFormMonitoring(activate: boolean);
9
10procedure MarkFormAsStayOnTop(Form: TForm; IsStayOnTop: Boolean);
11
12// Some forms have display tasks when first displayed that are messed up by the
13// form monitor - such as making a combo box automatically drop down. These forms
14// should call FormMonitorBringToFrontEvent, which will be called when the
15// form monitor calls the form's BringToFront method. The Seconds parameter is the
16// amount of time that must transpire before the form monitor will call
17// BringToFront again, unless another form has received focus since the event was called.
18
19procedure FormMonitorBringToFrontEvent(Form: TForm; AEvent: TNotifyEvent; Seconds: integer = 3);
20
21implementation
22
23const
24 TIMER_INTERVAL = 8;
25 TIMER_CHECKS_BEFORE_TIMEOUT = 1000 div TIMER_INTERVAL;
26
27type
28 TFormMonitor = class
29 private
30 FOldActiveFormChangeEvent: TNotifyEvent;
31 FOldActivateEvent: TNotifyEvent;
32 FOldRestore: TNotifyEvent;
33 FModifyingZOrder: boolean;
34 FModifyPending: boolean;
35 FActiveForm: TForm;
36 FZOrderHandles: TList;
37 FLastModal: boolean;
38 fTopOnList: TList;
39 fTopOffList: TList;
40 fTimer: TTimer;
41 FTimerCount: integer;
42 FMenuPending: boolean;
43 FWindowsHook: HHOOK;
44 FRunning: boolean;
45 FFormEvents: TObjectList;
46 FLastActiveFormHandle: HWND;
47 procedure ManageForms;
48 function FormValid(form: TForm): boolean;
49 function HandleValid(handle: HWND): boolean;
50 procedure MoveOnTop(Handle: HWND);
51 procedure MoveOffTop(Handle: HWND);
52 procedure Normalize(Handle: HWND; Yes: boolean);
53 procedure NormalizeReset;
54 function IsNormalized(Handle: HWND): boolean;
55 function GetActiveFormHandle: HWND;
56 procedure StartZOrdering;
57 function SystemRunning: boolean;
58 function ModalDelphiForm: boolean;
59 function IsTopMost(Handle: HWND): boolean;
60 public
61 procedure Start;
62 procedure Stop;
63 procedure Timer(Sender: TObject);
64 procedure Activate(Sender: TObject);
65 procedure ActiveFormChange(Sender: TObject);
66 procedure Restore(Sender: TObject);
67 end;
68
69 TFormEvent = class(TObject)
70 private
71 FForm: TForm;
72 FEvent: TNotifyEvent;
73 FSeconds: integer;
74 FTimeStamp: TDateTime;
75 end;
76
77var
78 FormMonitor: TFormMonitor = nil;
79
80type
81 HDisableGhostProc = procedure(); stdcall;
82
83const
84 NORMALIZED = $00000001;
85 UN_NORMALIZED = $FFFFFFFE;
86 STAY_ON_TOP = $00000002;
87 NORMAL_FORM = $FFFFFFFD;
88
89
90procedure DisableGhosting;
91const
92 DisableProc = 'DisableProcessWindowsGhosting';
93 UserDLL = 'user32.dll';
94
95var
96 DisableGhostProc: HDisableGhostProc;
97 User32Handle: THandle;
98
99begin
100 User32Handle := LoadLibrary(PChar(UserDLL));
101 try
102 if User32Handle <= HINSTANCE_ERROR then
103 User32Handle := 0
104 else
105 begin
106 DisableGhostProc := GetProcAddress(User32Handle, PChar(DisableProc));
107 if(assigned(DisableGhostProc)) then
108 begin
109 DisableGhostProc;
110 end;
111 end;
112 finally
113 if(User32Handle <> 0) then
114 FreeLibrary(User32Handle);
115 end;
116end;
117
118procedure SetFormMonitoring(activate: boolean);
119var
120 running: boolean;
121begin
122 running := assigned(FormMonitor);
123 if(activate <> running) then
124 begin
125 if(running) then
126 begin
127 FormMonitor.Stop;
128 FormMonitor.Free;
129 FormMonitor := nil;
130 end
131 else
132 begin
133 FormMonitor := TFormMonitor.Create;
134 FormMonitor.Start;
135 end;
136 end;
137end;
138
139procedure MarkFormAsStayOnTop(Form: TForm; IsStayOnTop: Boolean);
140var
141 Data: Longint;
142begin
143 Data := GetWindowLong(Form.Handle, GWL_USERDATA);
144 if(IsStayOnTop) then
145 begin
146 Data := Data or STAY_ON_TOP;
147 SetWindowPos(Form.Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE);
148 end
149 else
150 begin
151 Data := Data and NORMAL_FORM;
152 SetWindowPos(Form.Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE);
153 end;
154 SetWindowLong(Form.Handle, GWL_USERDATA, Data);
155end;
156
157function FindFormEventIndex(Form: TForm): integer;
158var
159 i: integer;
160 event: TFormEvent;
161begin
162 Result := -1;
163 for i := 0 to FormMonitor.FFormEvents.Count-1 do
164 begin
165 event := TFormEvent(FormMonitor.FFormEvents[i]);
166 if(event.FForm = Form) then
167 begin
168 Result := i;
169 exit;
170 end;
171 end;
172end;
173
174function FindFormEvent(Form: TForm): TFormEvent;
175var
176 idx: integer;
177begin
178 idx := FindFormEventIndex(Form);
179 if(idx < 0) then
180 Result := nil
181 else
182 Result := TFormEvent(FormMonitor.FFormEvents[idx]);
183end;
184
185procedure FormMonitorBringToFrontEvent(Form: TForm; AEvent: TNotifyEvent; Seconds: integer);
186var
187 event: TFormEvent;
188 idx: integer;
189begin
190 event := FindFormEvent(Form);
191 if(assigned(AEvent)) then
192 begin
193 if(event = nil) then
194 begin
195 event := TFormEvent.Create;
196 event.FForm := Form;
197 event.FTimeStamp := 0;
198 FormMonitor.FFormEvents.Add(event);
199 end;
200 event.FEvent := AEvent;
201 event.FSeconds := Seconds;
202 end
203 else
204 if(event <> nil) then
205 begin
206 idx := FindFormEventIndex(Form);
207 FormMonitor.FFormEvents.Delete(idx);
208// event.Free; - TObjectList frees object automatically
209 end;
210end;
211
212function IsFormStayOnTop(form: TForm): boolean;
213begin
214 Result := (form.FormStyle = fsStayOnTop);
215 if(not Result) then
216 Result := ((GetWindowLong(Form.Handle, GWL_USERDATA) and STAY_ON_TOP) <> 0);
217end;
218
219{ TFormMonitor }
220
221procedure TFormMonitor.Activate(Sender: TObject);
222begin
223 if(Assigned(FOldActivateEvent)) then
224 FOldActivateEvent(Sender);
225 NormalizeReset;
226 StartZOrdering;
227end;
228
229procedure TFormMonitor.ActiveFormChange(Sender: TObject);
230begin
231 if(Assigned(FOldActiveFormChangeEvent)) then
232 FOldActiveFormChangeEvent(Sender);
233 StartZOrdering;
234end;
235
236procedure TFormMonitor.Restore(Sender: TObject);
237begin
238 if(Assigned(FOldRestore)) then
239 FOldRestore(Sender);
240 NormalizeReset;
241 StartZOrdering;
242end;
243
244function TFormMonitor.FormValid(form: TForm): boolean;
245begin
246 Result := assigned(form);
247 if Result then
248 Result := (form.Parent = nil) and (form.ParentWindow = 0) and form.Visible and (form.Handle <> 0);
249end;
250
251function TFormMonitor.HandleValid(handle: HWND): boolean;
252begin
253 Result := (handle <> 0);
254 if(Result) then
255 Result := IsWindow(handle) and IsWindowVisible(handle) and isWindowEnabled(handle);
256end;
257
258function FindWindowZOrder(Window: HWnd; Data: Longint): Bool; stdcall;
259begin
260 if(IsWindow(Window) and IsWindowVisible(Window)) then
261 FormMonitor.FZOrderHandles.Add(Pointer(Window));
262 Result := True;
263end;
264
265procedure TFormMonitor.ManageForms;
266var
267 i, j: integer;
268 form: TForm;
269 formHandle, activeHandle: HWND;
270 modal, doCall: boolean;
271 event: TFormEvent;
272
273begin
274 if(FModifyingZOrder) then exit;
275 if(not SystemRunning) then exit;
276 FModifyingZOrder := TRUE;
277 try
278 activeHandle := GetActiveFormHandle;
279 if (activeHandle <> 0) and (not assigned(FactiveForm)) then
280 modal := true //assumes DLL created forms are modal
281 else
282 modal := ModalDelphiForm;
283 FZOrderHandles.Clear;
284 fTopOnList.Clear;
285 fTopOffList.Clear;
286
287 EnumThreadWindows(GetCurrentThreadID, @FindWindowZOrder, 0);
288 for i := 0 to FZOrderHandles.Count-1 do
289 begin
290 formHandle := HWND(FZOrderHandles[i]);
291 for j := 0 to Screen.FormCount-1 do
292 begin
293 form := Screen.Forms[j];
294 if(form.Handle = formHandle) then
295 begin
296 if formValid(form) and (form.Handle <> activeHandle) and IsFormStayOnTop(form) then
297 begin
298 if(modal and (not IsWindowEnabled(form.Handle))) then
299 fTopOffList.Add(Pointer(form.Handle))
300 else
301 fTopOnList.Add(Pointer(form.Handle));
302 end;
303 break;
304 end;
305 end;
306 end;
307 for i := fTopOffList.Count-1 downto 0 do
308 MoveOffTop(HWND(fTopOffList[i]));
309 for i := fTopOnList.Count-1 downto 0 do
310 MoveOnTop(HWND(fTopOnList[i]));
311
312 if(activeHandle <> 0) then
313 begin
314 if(assigned(FActiveForm)) then
315 begin
316 event := FindFormEvent(FActiveForm);
317 doCall := (event = nil);
318 if(not doCall) then
319 doCall := (activeHandle <> FLastActiveFormHandle);
320 if(not doCall) then
321 doCall := SecondsBetween(Now, event.FTimeStamp) > event.FSeconds;
322 if(doCall) then
323 begin
324 if IsFormStayOnTop(FActiveForm) then
325 begin
326 SetWindowPos(activeHandle, HWND_TOPMOST, 0, 0, 0, 0,
327 SWP_NOMOVE or SWP_NOSIZE);
328 Normalize(activeHandle, FALSE);
329 end;
330 FActiveForm.BringToFront;
331 if(event <> nil) then
332 begin
333 if(FormValid(event.FForm)) then
334 begin
335 event.FEvent(FActiveForm);
336 event.FTimeStamp := now;
337 end;
338 end;
339 end;
340 end
341 else
342 begin
343 if(activeHandle <> 0) then
344 begin
345 SetFocus(activeHandle);
346 BringWindowToTop(activeHandle);
347 if(IsTopMost(activeHandle)) then
348 SetWindowPos(activeHandle, HWND_TOPMOST, 0, 0, 0, 0,
349 SWP_NOMOVE or SWP_NOSIZE);
350 end;
351 end;
352 end;
353 FLastActiveFormHandle := activeHandle;
354 finally
355 FModifyingZOrder := FALSE;
356 end;
357end;
358
359function CallWndHook(Code: Integer; WParam: wParam; Msg: PCWPStruct): Longint; stdcall;
360begin
361 case Msg.message of
362 WM_INITMENU, WM_INITMENUPOPUP, WM_ENTERMENULOOP:
363 FormMonitor.FMenuPending := TRUE;
364 WM_MENUSELECT, WM_EXITMENULOOP:
365 FormMonitor.FMenuPending := FALSE;
366 end;
367 Result := CallNextHookEx(FormMonitor.FWindowsHook, Code, WParam, Longint(Msg));
368end;
369
370procedure TFormMonitor.Start;
371begin
372 if(FRunning) then exit;
373 FRunning := TRUE;
374 FTimer := TTimer.Create(Application);
375 fTimer.Enabled := FALSE;
376 FTimer.OnTimer := Timer;
377 FTimer.Interval := TIMER_INTERVAL;
378 FMenuPending := FALSE;
379 FLastActiveFormHandle := 0;
380
381 FZOrderHandles := TList.Create;
382 fTopOnList := TList.Create;
383 fTopOffList := TList.Create;
384 FFormEvents := TObjectList.Create;
385 FModifyingZOrder := false;
386 FLastModal := false;
387 FOldActiveFormChangeEvent := Screen.OnActiveFormChange;
388 Screen.OnActiveFormChange := ActiveFormChange;
389 FOldActivateEvent := Application.OnActivate;
390 Application.OnActivate := Activate;
391 FOldRestore := Application.OnRestore;
392 Application.OnRestore := Restore;
393 FWindowsHook := SetWindowsHookEx(WH_CALLWNDPROC, @CallWndHook, 0, GetCurrentThreadID)
394end;
395
396procedure TFormMonitor.Stop;
397begin
398 if(not FRunning) then exit;
399 FRunning := FALSE;
400 if FWindowsHook <> 0 then
401 begin
402 UnHookWindowsHookEx(FWindowsHook);
403 FWindowsHook := 0;
404 end;
405 Screen.OnActiveFormChange := FOldActiveFormChangeEvent;
406 Application.OnActivate := FOldActivateEvent;
407 Application.OnRestore := FOldRestore;
408
409 FZOrderHandles.Free;
410 fTopOnList.Free;
411 fTopOffList.Free;
412 FFormEvents.Free;
413 fTimer.Enabled := FALSE;
414 fTimer.Free;
415end;
416
417procedure TFormMonitor.MoveOffTop(Handle: HWND);
418begin
419 if(not IsNormalized(Handle)) then
420 begin
421 SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0,
422 SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);
423 Normalize(Handle, TRUE);
424 end;
425end;
426
427procedure TFormMonitor.MoveOnTop(Handle: HWND);
428begin
429 if(isNormalized(Handle)) then
430 begin
431 SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,
432 SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);
433 Normalize(Handle, FALSE);
434 end;
435end;
436
437procedure TFormMonitor.Normalize(Handle: HWND; Yes: boolean);
438var
439 Data: Longint;
440begin
441 Data := GetWindowLong(Handle, GWL_USERDATA);
442 if(yes) then
443 Data := Data or NORMALIZED
444 else
445 Data := Data and UN_NORMALIZED;
446 SetWindowLong(Handle, GWL_USERDATA, Data);
447end;
448
449function TFormMonitor.IsNormalized(Handle: HWND): boolean;
450begin
451 Result := ((GetWindowLong(Handle, GWL_USERDATA) and NORMALIZED) <> 0);
452end;
453
454function TFormMonitor.IsTopMost(Handle: HWND): boolean;
455begin
456 Result := ((GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0);
457end;
458
459function FindWindows(Window: HWnd; Data: Longint): Bool; stdcall;
460begin
461 FormMonitor.Normalize(Window, FALSE);
462 Result := True;
463end;
464
465procedure TFormMonitor.NormalizeReset;
466begin
467 EnumThreadWindows(GetCurrentThreadID, @FindWindows, 0);
468end;
469
470var
471 uActiveWindowHandle: HWND;
472 uActiveWindowCount: integer;
473
474function IsHandleOK(Handle: HWND): boolean;
475var
476 i: integer;
477
478begin
479 Result := FALSE;
480 if(not formMonitor.HandleValid(Handle)) or (Handle = Application.Handle) then exit;
481 for i := 0 to Screen.FormCount-1 do
482 begin
483 if(Handle = Screen.Forms[i].Handle) then exit;
484 end;
485 Result := TRUE;
486end;
487
488function FindActiveWindow(Window: HWnd; Data: Longint): Bool; stdcall;
489begin
490 Result := True;
491 if(IsHandleOK(Window)) then
492 begin
493 inc(uActiveWindowCount);
494 if(uActiveWindowCount = 1) then
495 uActiveWindowHandle := Window
496 else
497 if(uActiveWindowCount > 1) then
498 Result := false;
499 end;
500end;
501
502function TFormMonitor.GetActiveFormHandle: HWND;
503var
504 i: integer;
505 form: TForm;
506
507begin
508 FActiveForm := Screen.ActiveForm;
509 if(assigned(FActiveForm)) then
510 Result := FActiveForm.Handle
511 else
512 Result := 0;
513 if(FormValid(FActiveForm) and IsWindowEnabled(FActiveForm.Handle)) then
514 exit;
515 for i := 0 to Screen.FormCount-1 do
516 begin
517 form := Screen.Forms[i];
518 if(form.Handle = Result) then
519 begin
520 if FormValid(form) and IsWindowEnabled(form.Handle) then
521 begin
522 FActiveForm := form;
523 Result := form.Handle;
524 exit;
525 end;
526 end;
527 end;
528 FActiveForm := nil;
529 Result := GetActiveWindow;
530 if(IsHandleOK(Result)) then exit;
531 uActiveWindowHandle := 0;
532 uActiveWindowCount := 0;
533 EnumThreadWindows(GetCurrentThreadID, @FindActiveWindow, 0);
534 if(uActiveWindowCount = 1) then
535 begin
536 Result := uActiveWindowHandle;
537 end;
538end;
539
540
541procedure TFormMonitor.StartZOrdering;
542begin
543 if(FModifyPending) then exit;
544 if(SystemRunning) then
545 begin
546 FModifyPending := TRUE;
547 FTimerCount := 0;
548 FTimer.Enabled := TRUE;
549 end;
550end;
551
552function TFormMonitor.SystemRunning: boolean;
553begin
554 Result := assigned(Application.MainForm) and
555 (Application.MainForm.Handle <> 0) and
556 IsWindowVisible(Application.MainForm.Handle);
557end;
558
559
560function TFormMonitor.ModalDelphiForm: boolean;
561var
562 i: integer;
563 form: TForm;
564begin
565 for i := 0 to Screen.FormCount-1 do
566 begin
567 form := screen.Forms[i];
568 if(FormValid(form) and (fsModal in form.FormState)) then
569 begin
570 Result := TRUE;
571 exit;
572 end;
573 end;
574 Result := FALSE;
575end;
576
577procedure TFormMonitor.Timer(Sender: TObject);
578var
579 NoMenu: boolean;
580begin
581 inc(FTimerCount);
582 if(FTimerCount > TIMER_CHECKS_BEFORE_TIMEOUT) then
583 begin
584 FTimer.Enabled := FALSE;
585 FMenuPending := FALSE;
586 FModifyPending := FALSE;
587 exit;
588 end;
589 if(FTimerCount <> 1) then exit;
590 FTimer.Enabled := FALSE;
591 NoMenu := not FMenuPending;
592 FMenuPending := FALSE;
593 if(NoMenu and SystemRunning) then
594 ManageForms;
595 FModifyPending := FALSE;
596end;
597
598initialization
599 DisableGhosting;
600
601finalization
602
603end.
Note: See TracBrowser for help on using the repository browser.