VistA-cprs/CPRS-Chart/uFormMonitor.pas

597 lines
15 KiB
Plaintext
Raw Normal View History

unit uFormMonitor;
interface
uses
SysUtils, Forms, Classes, Windows, Messages, ExtCtrls, Contnrs, DateUtils;
procedure SetFormMonitoring(activate: boolean);
procedure MarkFormAsStayOnTop(Form: TForm; IsStayOnTop: Boolean);
// Some forms have display tasks when first displayed that are messed up by the
// form monitor - such as making a combo box automatically drop down. These forms
// should call FormMonitorBringToFrontEvent, which will be called when the
// form monitor calls the form's BringToFront method. The Seconds parameter is the
// amount of time that must transpire before the form monitor will call
// BringToFront again, unless another form has received focus since the event was called.
procedure FormMonitorBringToFrontEvent(Form: TForm; AEvent: TNotifyEvent; Seconds: integer = 3);
implementation
type
TFormMonitor = class
private
FOldActiveFormChangeEvent: TNotifyEvent;
FOldActivateEvent: TNotifyEvent;
FOldRestore: TNotifyEvent;
FModifyingZOrder: boolean;
FModifyPending: boolean;
FActiveForm: TForm;
FZOrderHandles: TList;
FLastModal: boolean;
fTopOnList: TList;
fTopOffList: TList;
fTimer: TTimer;
FTimerCount: integer;
FMenuPending: boolean;
FWindowsHook: HHOOK;
FRunning: boolean;
FFormEvents: TObjectList;
FLastActiveFormHandle: HWND;
procedure ManageForms;
function FormValid(form: TForm): boolean;
function HandleValid(handle: HWND): boolean;
procedure MoveOnTop(Handle: HWND);
procedure MoveOffTop(Handle: HWND);
procedure Normalize(Handle: HWND; Yes: boolean);
procedure NormalizeReset;
function IsNormalized(Handle: HWND): boolean;
function GetActiveFormHandle: HWND;
procedure StartZOrdering;
function SystemRunning: boolean;
function ModalDelphiForm: boolean;
function IsTopMost(Handle: HWND): boolean;
public
procedure Start;
procedure Stop;
procedure Timer(Sender: TObject);
procedure Activate(Sender: TObject);
procedure ActiveFormChange(Sender: TObject);
procedure Restore(Sender: TObject);
end;
TFormEvent = class(TObject)
private
FForm: TForm;
FEvent: TNotifyEvent;
FSeconds: integer;
FTimeStamp: TDateTime;
end;
var
FormMonitor: TFormMonitor = nil;
type
HDisableGhostProc = procedure(); stdcall;
const
NORMALIZED = $00000001;
UN_NORMALIZED = $FFFFFFFE;
STAY_ON_TOP = $00000002;
NORMAL_FORM = $FFFFFFFD;
procedure DisableGhosting;
const
DisableProc = 'DisableProcessWindowsGhosting';
UserDLL = 'user32.dll';
var
DisableGhostProc: HDisableGhostProc;
User32Handle: THandle;
begin
User32Handle := LoadLibrary(PChar(UserDLL));
try
if User32Handle <= HINSTANCE_ERROR then
User32Handle := 0
else
begin
DisableGhostProc := GetProcAddress(User32Handle, PChar(DisableProc));
if(assigned(DisableGhostProc)) then
begin
DisableGhostProc;
end;
end;
finally
if(User32Handle <> 0) then
FreeLibrary(User32Handle);
end;
end;
procedure SetFormMonitoring(activate: boolean);
var
running: boolean;
begin
running := assigned(FormMonitor);
if(activate <> running) then
begin
if(running) then
begin
FormMonitor.Stop;
FormMonitor.Free;
FormMonitor := nil;
end
else
begin
FormMonitor := TFormMonitor.Create;
FormMonitor.Start;
end;
end;
end;
procedure MarkFormAsStayOnTop(Form: TForm; IsStayOnTop: Boolean);
var
Data: Longint;
begin
Data := GetWindowLong(Form.Handle, GWL_USERDATA);
if(IsStayOnTop) then
begin
Data := Data or STAY_ON_TOP;
SetWindowPos(Form.Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE);
end
else
begin
Data := Data and NORMAL_FORM;
SetWindowPos(Form.Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE);
end;
SetWindowLong(Form.Handle, GWL_USERDATA, Data);
end;
function FindFormEventIndex(Form: TForm): integer;
var
i: integer;
event: TFormEvent;
begin
Result := -1;
for i := 0 to FormMonitor.FFormEvents.Count-1 do
begin
event := TFormEvent(FormMonitor.FFormEvents[i]);
if(event.FForm = Form) then
begin
Result := i;
exit;
end;
end;
end;
function FindFormEvent(Form: TForm): TFormEvent;
var
idx: integer;
begin
idx := FindFormEventIndex(Form);
if(idx < 0) then
Result := nil
else
Result := TFormEvent(FormMonitor.FFormEvents[idx]);
end;
procedure FormMonitorBringToFrontEvent(Form: TForm; AEvent: TNotifyEvent; Seconds: integer);
var
event: TFormEvent;
idx: integer;
begin
event := FindFormEvent(Form);
if(assigned(AEvent)) then
begin
if(event = nil) then
begin
event := TFormEvent.Create;
event.FForm := Form;
event.FTimeStamp := 0;
FormMonitor.FFormEvents.Add(event);
end;
event.FEvent := AEvent;
event.FSeconds := Seconds;
end
else
if(event <> nil) then
begin
idx := FindFormEventIndex(Form);
FormMonitor.FFormEvents.Delete(idx);
// event.Free; - TObjectList frees object automatically
end;
end;
function IsFormStayOnTop(form: TForm): boolean;
begin
Result := (form.FormStyle = fsStayOnTop);
if(not Result) then
Result := ((GetWindowLong(Form.Handle, GWL_USERDATA) and STAY_ON_TOP) <> 0);
end;
{ TFormMonitor }
procedure TFormMonitor.Activate(Sender: TObject);
begin
if(Assigned(FOldActivateEvent)) then
FOldActivateEvent(Sender);
NormalizeReset;
StartZOrdering;
end;
procedure TFormMonitor.ActiveFormChange(Sender: TObject);
begin
if(Assigned(FOldActiveFormChangeEvent)) then
FOldActiveFormChangeEvent(Sender);
StartZOrdering;
end;
procedure TFormMonitor.Restore(Sender: TObject);
begin
if(Assigned(FOldRestore)) then
FOldRestore(Sender);
NormalizeReset;
StartZOrdering;
end;
function TFormMonitor.FormValid(form: TForm): boolean;
begin
Result := assigned(form);
if Result then
Result := (form.Parent = nil) and (form.ParentWindow = 0) and form.Visible and (form.Handle <> 0);
end;
function TFormMonitor.HandleValid(handle: HWND): boolean;
begin
Result := (handle <> 0);
if(Result) then
Result := IsWindow(handle) and IsWindowVisible(handle) and isWindowEnabled(handle);
end;
function FindWindowZOrder(Window: HWnd; Data: Longint): Bool; stdcall;
begin
if(IsWindow(Window) and IsWindowVisible(Window)) then
FormMonitor.FZOrderHandles.Add(Pointer(Window));
Result := True;
end;
procedure TFormMonitor.ManageForms;
var
i, j: integer;
form: TForm;
formHandle, activeHandle: HWND;
modal, doCall: boolean;
event: TFormEvent;
begin
if(FModifyingZOrder) then exit;
if(not SystemRunning) then exit;
FModifyingZOrder := TRUE;
try
activeHandle := GetActiveFormHandle;
modal := ModalDelphiForm;
FZOrderHandles.Clear;
fTopOnList.Clear;
fTopOffList.Clear;
EnumThreadWindows(GetCurrentThreadID, @FindWindowZOrder, 0);
for i := 0 to FZOrderHandles.Count-1 do
begin
formHandle := HWND(FZOrderHandles[i]);
for j := 0 to Screen.FormCount-1 do
begin
form := Screen.Forms[j];
if(form.Handle = formHandle) then
begin
if formValid(form) and (form.Handle <> activeHandle) and IsFormStayOnTop(form) then
begin
if(modal and (not IsWindowEnabled(form.Handle))) then
fTopOffList.Add(Pointer(form.Handle))
else
fTopOnList.Add(Pointer(form.Handle));
end;
break;
end;
end;
end;
for i := fTopOffList.Count-1 downto 0 do
MoveOffTop(HWND(fTopOffList[i]));
for i := fTopOnList.Count-1 downto 0 do
MoveOnTop(HWND(fTopOnList[i]));
if(activeHandle <> 0) then
begin
if(assigned(FActiveForm)) then
begin
event := FindFormEvent(FActiveForm);
doCall := (event = nil);
if(not doCall) then
doCall := (activeHandle <> FLastActiveFormHandle);
if(not doCall) then
doCall := SecondsBetween(Now, event.FTimeStamp) > event.FSeconds;
if(doCall) then
begin
if IsFormStayOnTop(FActiveForm) then
begin
SetWindowPos(activeHandle, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE);
Normalize(activeHandle, FALSE);
end;
FActiveForm.BringToFront;
if(event <> nil) then
begin
if(FormValid(event.FForm)) then
begin
event.FEvent(FActiveForm);
event.FTimeStamp := now;
end;
end;
end;
end
else
begin
if(activeHandle <> 0) then
begin
SetFocus(activeHandle);
BringWindowToTop(activeHandle);
if(IsTopMost(activeHandle)) then
SetWindowPos(activeHandle, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE);
end;
end;
end;
FLastActiveFormHandle := activeHandle;
finally
FModifyingZOrder := FALSE;
end;
end;
function CallWndHook(Code: Integer; WParam: wParam; Msg: PCWPStruct): Longint; stdcall;
begin
case Msg.message of
WM_INITMENU, WM_INITMENUPOPUP, WM_ENTERMENULOOP:
FormMonitor.FMenuPending := TRUE;
WM_MENUSELECT, WM_EXITMENULOOP:
FormMonitor.FMenuPending := FALSE;
end;
Result := CallNextHookEx(FormMonitor.FWindowsHook, Code, WParam, Longint(Msg));
end;
procedure TFormMonitor.Start;
begin
if(FRunning) then exit;
FRunning := TRUE;
FTimer := TTimer.Create(Application);
fTimer.Enabled := FALSE;
FTimer.OnTimer := Timer;
FTimer.Interval := 10;
FMenuPending := FALSE;
FLastActiveFormHandle := 0;
FZOrderHandles := TList.Create;
fTopOnList := TList.Create;
fTopOffList := TList.Create;
FFormEvents := TObjectList.Create;
FModifyingZOrder := false;
FLastModal := false;
FOldActiveFormChangeEvent := Screen.OnActiveFormChange;
Screen.OnActiveFormChange := ActiveFormChange;
FOldActivateEvent := Application.OnActivate;
Application.OnActivate := Activate;
FOldRestore := Application.OnRestore;
Application.OnRestore := Restore;
FWindowsHook := SetWindowsHookEx(WH_CALLWNDPROC, @CallWndHook, 0, GetCurrentThreadID)
end;
procedure TFormMonitor.Stop;
begin
if(not FRunning) then exit;
FRunning := FALSE;
if FWindowsHook <> 0 then
begin
UnHookWindowsHookEx(FWindowsHook);
FWindowsHook := 0;
end;
Screen.OnActiveFormChange := FOldActiveFormChangeEvent;
Application.OnActivate := FOldActivateEvent;
Application.OnRestore := FOldRestore;
FZOrderHandles.Free;
fTopOnList.Free;
fTopOffList.Free;
FFormEvents.Free;
fTimer.Enabled := FALSE;
fTimer.Free;
end;
procedure TFormMonitor.MoveOffTop(Handle: HWND);
begin
if(not IsNormalized(Handle)) then
begin
SetWindowPos(Handle, HWND_NOTOPMOST, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);
Normalize(Handle, TRUE);
end;
end;
procedure TFormMonitor.MoveOnTop(Handle: HWND);
begin
if(isNormalized(Handle)) then
begin
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0,
SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE or SWP_NOOWNERZORDER);
Normalize(Handle, FALSE);
end;
end;
procedure TFormMonitor.Normalize(Handle: HWND; Yes: boolean);
var
Data: Longint;
begin
Data := GetWindowLong(Handle, GWL_USERDATA);
if(yes) then
Data := Data or NORMALIZED
else
Data := Data and UN_NORMALIZED;
SetWindowLong(Handle, GWL_USERDATA, Data);
end;
function TFormMonitor.IsNormalized(Handle: HWND): boolean;
begin
Result := ((GetWindowLong(Handle, GWL_USERDATA) and NORMALIZED) <> 0);
end;
function TFormMonitor.IsTopMost(Handle: HWND): boolean;
begin
Result := ((GetWindowLong(Handle, GWL_EXSTYLE) and WS_EX_TOPMOST) <> 0);
end;
function FindWindows(Window: HWnd; Data: Longint): Bool; stdcall;
begin
FormMonitor.Normalize(Window, FALSE);
Result := True;
end;
procedure TFormMonitor.NormalizeReset;
begin
EnumThreadWindows(GetCurrentThreadID, @FindWindows, 0);
end;
var
uActiveWindowHandle: HWND;
uActiveWindowCount: integer;
function IsHandleOK(Handle: HWND): boolean;
var
i: integer;
begin
Result := FALSE;
if(not formMonitor.HandleValid(Handle)) or (Handle = Application.Handle) then exit;
for i := 0 to Screen.FormCount-1 do
begin
if(Handle = Screen.Forms[i].Handle) then exit;
end;
Result := TRUE;
end;
function FindActiveWindow(Window: HWnd; Data: Longint): Bool; stdcall;
begin
Result := True;
if(IsHandleOK(Window)) then
begin
inc(uActiveWindowCount);
if(uActiveWindowCount = 1) then
uActiveWindowHandle := Window
else
if(uActiveWindowCount > 1) then
Result := false;
end;
end;
function TFormMonitor.GetActiveFormHandle: HWND;
var
i: integer;
form: TForm;
begin
FActiveForm := Screen.ActiveForm;
if(assigned(FActiveForm)) then
Result := FActiveForm.Handle
else
Result := 0;
if(FormValid(FActiveForm) and IsWindowEnabled(FActiveForm.Handle)) then
exit;
for i := 0 to Screen.FormCount-1 do
begin
form := Screen.Forms[i];
if(form.Handle = Result) then
begin
if FormValid(form) and IsWindowEnabled(form.Handle) then
begin
FActiveForm := form;
Result := form.Handle;
exit;
end;
end;
end;
FActiveForm := nil;
Result := GetActiveWindow;
if(IsHandleOK(Result)) then exit;
uActiveWindowHandle := 0;
uActiveWindowCount := 0;
EnumThreadWindows(GetCurrentThreadID, @FindActiveWindow, 0);
if(uActiveWindowCount = 1) then
begin
Result := uActiveWindowHandle;
end;
end;
procedure TFormMonitor.StartZOrdering;
begin
if(FModifyPending) then exit;
if(SystemRunning) then
begin
FModifyPending := TRUE;
FTimerCount := 0;
FTimer.Enabled := TRUE;
end;
end;
function TFormMonitor.SystemRunning: boolean;
begin
Result := assigned(Application.MainForm) and
(Application.MainForm.Handle <> 0) and
IsWindowVisible(Application.MainForm.Handle);
end;
function TFormMonitor.ModalDelphiForm: boolean;
var
i: integer;
form: TForm;
begin
for i := 0 to Screen.FormCount-1 do
begin
form := screen.Forms[i];
if(FormValid(form) and (fsModal in form.FormState)) then
begin
Result := TRUE;
exit;
end;
end;
Result := FALSE;
end;
procedure TFormMonitor.Timer(Sender: TObject);
var
NoMenu: boolean;
begin
inc(FTimerCount);
if(FTimerCount > 20) then
begin
FTimer.Enabled := FALSE;
FMenuPending := FALSE;
FModifyPending := FALSE;
exit;
end;
if(FTimerCount <> 1) then exit;
FTimer.Enabled := FALSE;
NoMenu := not FMenuPending;
FMenuPending := FALSE;
if(NoMenu and SystemRunning) then
ManageForms;
FModifyPending := FALSE;
end;
initialization
DisableGhosting;
finalization
end.