mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-11-04 08:19:53 +01:00
1699 lines
53 KiB
PHP
1699 lines
53 KiB
PHP
{%MainUnit ../forms.pp}
|
|
{******************************************************************************
|
|
TApplication
|
|
******************************************************************************
|
|
|
|
*****************************************************************************
|
|
* *
|
|
* This file is part of the Lazarus Component Library (LCL) *
|
|
* *
|
|
* See the file COPYING.modifiedLGPL, included in this distribution, *
|
|
* for details about the copyright. *
|
|
* *
|
|
* This program is distributed in the hope that it will be useful, *
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
|
|
* *
|
|
*****************************************************************************
|
|
}
|
|
|
|
|
|
const
|
|
DefHintColor = clInfoBk; { default hint window color }
|
|
DefHintPause = 500; { default pause before hint window displays (ms) }
|
|
DefHintShortPause = 0; { default reshow pause }
|
|
DefHintHidePause = 5*DefHintPause; { default pause before hint is hidden (ms) }
|
|
DefHintHidePausePerChar = 200; { added to DefHintHidePause (ms) }
|
|
|
|
function FindApplicationComponent(const ComponentName: string): TComponent;
|
|
begin
|
|
if Application.FindGlobalComponentEnabled then begin
|
|
Result:=Application.FindComponent(ComponentName);
|
|
if Result=nil then
|
|
Result:=Screen.FindForm(ComponentName);
|
|
end else
|
|
Result:=nil;
|
|
//debugln('FindApplicationComponent ComponentName="',ComponentName,'" Result=',DbgSName(Result));
|
|
end;
|
|
|
|
function GetHintControl(Control: TControl): TControl;
|
|
begin
|
|
Result := Control;
|
|
while (Result <> nil) and (not (Result.ShowHint and Result.Enabled)) do
|
|
Result := Result.Parent;
|
|
if (Result <> nil)
|
|
and ([csDesigning,csDestroying,csLoading]*Result.ComponentState<>[]) then
|
|
Result := nil;
|
|
end;
|
|
|
|
function GetHintInfoAtMouse: THintInfoAtMouse;
|
|
begin
|
|
if Mouse<>nil then begin
|
|
Result.MousePos:=Mouse.CursorPos;
|
|
Result.Control:=GetHintControl(FindLCLControl(Result.MousePos));
|
|
Result.ControlHasHint:=
|
|
(Result.Control<>nil)
|
|
and (Application<>nil) and (Application.ShowHint)
|
|
and (GetCapture=0)
|
|
and ((GetKeyState(VK_LBUTTON) and $80)=0)
|
|
and ((GetKeyState(VK_MBUTTON) and $80)=0)
|
|
and ((GetKeyState(VK_RBUTTON) and $80)=0);
|
|
if Result.ControlHasHint then begin
|
|
// if there is a modal form, then don't show hints for other forms
|
|
if (Screen.FFocusedForm<>nil)
|
|
and (fsModal in Screen.FFocusedForm.FormState)
|
|
and (GetParentForm(Result.Control)<>Screen.FFocusedForm)
|
|
then
|
|
Result.ControlHasHint:=false;
|
|
end;
|
|
end else begin
|
|
Result.MousePos:=Point(0,0);
|
|
Result.Control:=nil;
|
|
Result.ControlHasHint:=false;
|
|
end;
|
|
end;
|
|
|
|
// Callback function for SysUtils.OnGetApplicationName;
|
|
function GetApplicationName: string;
|
|
begin
|
|
if Assigned(Application) then
|
|
Result := Application.Title;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication Constructor
|
|
------------------------------------------------------------------------------}
|
|
constructor TApplication.Create(AOwner: TComponent);
|
|
begin
|
|
Focusmessages := True;
|
|
LCLProc.SendApplicationMessageFunction:=@SendApplicationMsg;
|
|
|
|
FMainForm := nil;
|
|
FMouseControl := nil;
|
|
FHintColor := DefHintColor;
|
|
FHintPause := DefHintPause;
|
|
FHintShortCuts := True;
|
|
FHintShortPause := DefHintShortPause;
|
|
FHintHidePause := DefHintHidePause;
|
|
FHintHidePausePerChar := DefHintHidePausePerChar;
|
|
FShowHint := true;
|
|
FShowMainForm := true;
|
|
FFormList := nil;
|
|
FOnIdle := nil;
|
|
FIcon := nil;
|
|
FNavigation := [anoTabToSelectNext,anoReturnForDefaultControl,
|
|
anoEscapeForCancelControl,anoF1ForHelp];
|
|
ApplicationActionComponent:=Self;
|
|
OnMenuPopupHandler:=@MenuPopupHandler;
|
|
|
|
FFindGlobalComponentEnabled:=true;
|
|
RegisterFindGlobalComponentProc(@FindApplicationComponent);
|
|
|
|
inherited Create(AOwner);
|
|
CaptureExceptions:=true;
|
|
|
|
FOldExitProc:=ExitProc;
|
|
ExitProc:=@BeforeFinalization;
|
|
|
|
OnGetApplicationName := @GetApplicationName;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication Destructor
|
|
------------------------------------------------------------------------------}
|
|
destructor TApplication.Destroy;
|
|
var
|
|
HandlerType: TApplicationHandlerType;
|
|
begin
|
|
if Self=nil then
|
|
RaiseGDBException('TApplication.Destroy Self=nil');
|
|
Include(FFlags,AppDestroying);
|
|
|
|
if Assigned(FOnDestroy) then FOnDestroy(Self);
|
|
|
|
ExitProc:=FOldExitProc;
|
|
|
|
ProcessAsyncCallQueue;
|
|
if OnMenuPopupHandler=@MenuPopupHandler then
|
|
OnMenuPopupHandler:=nil;
|
|
|
|
// shutting down
|
|
CancelHint;
|
|
ShowHint := False;
|
|
|
|
// destroying
|
|
ApplicationActionComponent:=nil;
|
|
FreeThenNil(FIcon);
|
|
FreeThenNil(FFormList);
|
|
|
|
for HandlerType:=Low(TApplicationHandlerType) to High(TApplicationHandlerType)
|
|
do
|
|
FreeThenNil(FApplicationHandlers[HandlerType]);
|
|
|
|
UnregisterFindGlobalComponentProc(@FindApplicationComponent);
|
|
|
|
inherited Destroy;
|
|
|
|
Include(FFlags,AppDoNotCallAsyncQueue);
|
|
ProcessAsyncCallQueue;
|
|
|
|
// restore exception handling
|
|
CaptureExceptions:=false;
|
|
LCLProc.SendApplicationMessageFunction:=nil;
|
|
OnGetApplicationName := nil;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication BringToFront
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.BringToFront;
|
|
begin
|
|
WidgetSet.AppBringToFront;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication Messagebox
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.MessageBox(Text, Caption : PChar; Flags : Longint) : Integer;
|
|
begin
|
|
if Assigned(MessageBoxFunction) then
|
|
Result:=MessageBoxFunction(Text,Caption,Flags)
|
|
else begin
|
|
DebugLn('WARNING: TApplication.MessageBox: no MessageBoxFunction');
|
|
DebugLn(' Caption="',Caption,'"');
|
|
DebugLn(' Text="',Text,'"');
|
|
DebugLn(' Flags=',DbgS(Flags));
|
|
Result:=0;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication GetExename
|
|
------------------------------------------------------------------------------}
|
|
Function TApplication.GetExeName: String;
|
|
Begin
|
|
Result := ParamStr(0);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication Notification "Performs Application Level Operations"
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.Notification(AComponent : TComponent;
|
|
Operation : TOperation);
|
|
begin
|
|
if Operation = opRemove then begin
|
|
FLastMouseControlValid:=false;
|
|
if AComponent=FMouseControl then
|
|
FMouseControl:=nil;
|
|
if AComponent=FCreatingForm then
|
|
FCreatingForm:=nil;
|
|
if AComponent=FHintWindow then
|
|
FHintWindow:=nil;
|
|
if AComponent=FHintTimer then
|
|
FHintTimer:=nil;
|
|
if FComponentsToRelease<>nil then
|
|
FComponentsToRelease.Remove(AComponent);
|
|
if AComponent = MainForm then begin
|
|
FMainForm:= nil;
|
|
Terminate;
|
|
end;
|
|
end;
|
|
inherited Notification(AComponent,Operation);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.ControlDestroyed
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.ControlDestroyed(AControl: TControl);
|
|
begin
|
|
FLastMouseControlValid:=false;
|
|
if AControl=FMouseControl then FMouseControl:=nil;
|
|
if AControl = MainForm then FMainForm:= nil;
|
|
if AControl = FCreatingForm then FCreatingForm:= nil;
|
|
if Screen.FActiveControl = AControl then Screen.FActiveControl := nil;
|
|
if Screen.FActiveCustomForm = AControl then
|
|
begin
|
|
Screen.FActiveCustomForm := nil;
|
|
Screen.FActiveForm := nil;
|
|
end;
|
|
if Screen.FFocusedForm = AControl then Screen.FFocusedForm := nil;
|
|
if FHintControl = AControl then FHintControl:=nil;
|
|
Screen.UpdateLastActive;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.Minimize
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Minimizes the application.
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.Minimize;
|
|
begin
|
|
//debugln('TApplication.Minimize');
|
|
WidgetSet.AppMinimize;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.Restore
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Restore minimized application.
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.Restore;
|
|
begin
|
|
//debugln('TApplication.Restore');
|
|
WidgetSet.AppRestore;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication ProcesssMessages "Enter the messageloop and process until empty"
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.ProcessMessages;
|
|
begin
|
|
WidgetSet.AppProcessMessages;
|
|
ProcessAsyncCallQueue;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.Idle
|
|
Params: Wait: wait till something happens
|
|
Returns: Nothing
|
|
|
|
Invoked when the application enters the idle state
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.Idle(Wait: boolean);
|
|
var
|
|
Done: Boolean;
|
|
begin
|
|
ProcessAsyncCallQueue;
|
|
MouseIdle(GetControlAtMouse);
|
|
|
|
Done := True;
|
|
if (FIdleLockCount=0) then begin
|
|
if Assigned(FOnIdle) then FOnIdle(Self, Done);
|
|
if Done then
|
|
NotifyIdleHandler(Done);
|
|
end;
|
|
if Done
|
|
then begin
|
|
// wait till something happens
|
|
if (FIdleLockCount=0) then
|
|
DoIdleActions;
|
|
Include(FFlags,AppWaiting);
|
|
Exclude(FFlags,AppIdleEndSent);
|
|
if Wait then
|
|
WidgetSet.AppWaitMessage;
|
|
if (FIdleLockCount=0) then
|
|
DoOnIdleEnd;
|
|
Exclude(FFlags,AppWaiting);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication HintMouseMEssage
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.HintMouseMessage(Control : TControl;
|
|
var AMessage : TLMessage);
|
|
begin
|
|
// ToDo
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication Initialize
|
|
Makes a call to the component engine to provide any initialization that
|
|
needs to occur.
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.Initialize;
|
|
begin
|
|
inherited Initialize;
|
|
// interface object and screen
|
|
if (WidgetSet=nil)
|
|
// or (AnsiCompareText(WidgetSet.Classname,'TWIDGETSET')=0)
|
|
or (WidgetSet.ClassType = TWidgetSet)
|
|
then begin
|
|
DebugLn('ERROR: ',rsNoWidgetSet);
|
|
raise Exception.Create(rsNoWidgetSet);
|
|
end;
|
|
WidgetSet.AppInit(ScreenInfo);
|
|
ScreenInfo.Initialized:=true;
|
|
Screen.UpdateScreen;
|
|
// application icon
|
|
if LazarusResources.Find('MAINICON')<>nil then begin
|
|
if FIcon=nil then begin
|
|
FIcon:=TIcon.Create;
|
|
FIcon.OnChange := @IconChanged;
|
|
end;
|
|
FIcon.LoadFromLazarusResource('MAINICON');
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.MouseIdle
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Handles mouse Idle
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.MouseIdle(const CurrentControl: TControl);
|
|
begin
|
|
if FMouseControl <> CurrentControl then begin
|
|
UpdateMouseControl(CurrentControl);
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.SetCaptureExceptions(const AValue: boolean);
|
|
begin
|
|
if FCaptureExceptions=AValue then exit;
|
|
FCaptureExceptions:=AValue;
|
|
if FCaptureExceptions then begin
|
|
// capture exceptions
|
|
// store old exceptproc
|
|
if FOldExceptProc=nil then
|
|
FOldExceptProc:=ExceptProc;
|
|
ExceptProc:=@ExceptionOccurred;
|
|
end else begin
|
|
// do not capture exceptions
|
|
if ExceptProc=@ExceptionOccurred then begin
|
|
// restore old exceptproc
|
|
ExceptProc:=FOldExceptProc;
|
|
FOldExceptProc:=nil;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.InvokeHelp(Command: Word; Data: Longint): Boolean;
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.InvokeHelp(Command: Word; Data: Longint): Boolean;
|
|
var
|
|
CallHelp: Boolean;
|
|
ActiveForm: TCustomForm;
|
|
begin
|
|
Result := False;
|
|
CallHelp := True;
|
|
ActiveForm := Screen.ActiveCustomForm;
|
|
|
|
{ let existing hooks get called, if any. }
|
|
if Assigned(ActiveForm) and Assigned(ActiveForm.FOnHelp) then
|
|
Result := ActiveForm.FOnHelp(Command, Data, CallHelp)
|
|
else if Assigned(FOnHelp) then
|
|
Result := FOnHelp(Command, Data, CallHelp);
|
|
|
|
if CallHelp then begin
|
|
if Assigned(ActiveForm) and ActiveForm.HandleAllocated
|
|
and (ActiveForm.FHelpFile <> '') then
|
|
begin
|
|
|
|
end
|
|
else
|
|
if HelpFile <> '' then
|
|
begin
|
|
|
|
end else begin
|
|
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.GetControlAtMouse: TControl;
|
|
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.GetControlAtMouse: TControl;
|
|
var
|
|
P: TPoint;
|
|
begin
|
|
GetCursorPos(P);
|
|
//debugln(['TApplication.GetControlAtMouse p=',dbgs(p),' FLastMousePos=',dbgs(FLastMousePos)]);
|
|
if FLastMouseControlValid and (P.X=FLastMousePos.x) and (P.Y=FLastMousePos.Y)
|
|
then
|
|
Result := FLastMouseControl
|
|
else
|
|
Result := FindControlAtPosition(P, True);
|
|
|
|
if (Result <> nil) and (csDesigning in Result.ComponentState) then
|
|
Result := nil;
|
|
if Result<> nil then begin
|
|
FLastMouseControlValid:=true;
|
|
FLastMousePos:=p;
|
|
FLastMouseControl:=Result;
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.SetFlags(const AValue: TApplicationFlags);
|
|
begin
|
|
{ Only allow AppNoExceptionMessages to be changed }
|
|
FFlags := Flags - [AppNoExceptionMessages] + AValue*[AppNoExceptionMessages];
|
|
end;
|
|
|
|
procedure TApplication.SetNavigation(const AValue: TApplicationNavigationOptions
|
|
);
|
|
begin
|
|
if FNavigation=AValue then exit;
|
|
FNavigation:=AValue;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.UpdateMouseControl(NewMouseControl: TControl);
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.UpdateMouseControl(NewMouseControl: TControl);
|
|
begin
|
|
//debugln(['TApplication.UpdateMouseControl Old=',DbgSName(FMouseControl),' New=',DbgSName(NewMouseControl)]);
|
|
if FMouseControl=NewMouseControl then exit;
|
|
if (FMouseControl<>nil) then begin
|
|
//DebugLn' MOUSELEAVE=',FMouseControl.Name,':',FMouseControl.ClassName);
|
|
FMouseControl.Perform(CM_MOUSELEAVE, 0, 0);
|
|
end;
|
|
FMouseControl := NewMouseControl;
|
|
if (FMouseControl<>nil) then begin
|
|
//DebugLn' MOUSEENTER=',FMouseControl.Name,':',FMouseControl.ClassName);
|
|
FMouseControl.Perform(CM_MOUSEENTER, 0, 0);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.SetIcon
|
|
Params: the new icon
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.SetIcon(AValue: TIcon);
|
|
begin
|
|
if FIcon=nil then begin
|
|
FIcon:=TIcon.Create;
|
|
FIcon.OnChange := @IconChanged;
|
|
end;
|
|
FIcon.Assign(AValue);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.SetShowHint(const AValue: Boolean);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.SetShowHint(const AValue: Boolean);
|
|
begin
|
|
if FShowHint=AValue then exit;
|
|
FShowHint:=AValue;
|
|
if FShowHint then
|
|
begin
|
|
//
|
|
end else
|
|
begin
|
|
FreeThenNil(FHintWindow);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.SetTitle(const AValue: String);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.SetTitle(const AValue: String);
|
|
begin
|
|
inherited SetTitle(AValue);
|
|
WidgetSet.AppSetTitle(GetTitle);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.StopHintTimer;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.StopHintTimer;
|
|
begin
|
|
if FHintTimer<>nil then
|
|
FHintTimer.Enabled:=false;
|
|
FHintTimerType:=ahtNone;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.ValidateHelpSystem;
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.ValidateHelpSystem: Boolean;
|
|
begin
|
|
Result:=HelpManager<>nil;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.NotifyIdleHandler(var Done: Boolean);
|
|
|
|
Done = true will wait for the next message
|
|
Done = false will repeat calling the OnIdle handlers
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.NotifyIdleHandler(var Done: Boolean);
|
|
var
|
|
i: LongInt;
|
|
begin
|
|
i:=FApplicationHandlers[ahtIdle].Count;
|
|
while FApplicationHandlers[ahtIdle].NextDownIndex(i) do begin
|
|
TIdleEvent(FApplicationHandlers[ahtIdle][i])(Self,Done);
|
|
if not Done then exit;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.NotifyIdleEndHandler;
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.NotifyIdleEndHandler;
|
|
begin
|
|
FApplicationHandlers[ahtIdleEnd].CallNotifyEvents(Self);
|
|
end;
|
|
|
|
procedure TApplication.NotifyActivateHandler;
|
|
begin
|
|
if Assigned(OnActivate) then OnActivate(Self);
|
|
FApplicationHandlers[ahtActivate].CallNotifyEvents(Self);
|
|
end;
|
|
|
|
procedure TApplication.NotifyDeactivateHandler;
|
|
begin
|
|
if Assigned(OnDeactivate) then OnDeactivate(Self);
|
|
FApplicationHandlers[ahtDeactivate].CallNotifyEvents(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.IsHintMsg(var Msg: TMsg): Boolean;
|
|
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.IsHintMsg(var Msg: TMsg): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.DoOnMouseMove;
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.DoOnMouseMove;
|
|
var
|
|
Info: THintInfoAtMouse;
|
|
begin
|
|
Info:=GetHintInfoAtMouse;
|
|
//DebugLn('TApplication.DoOnMouseMove Info.ControlHasHint=',dbgs(Info.ControlHasHint),' Type=',dbgs(ord(FHintTimerType)),' FHintControl=',DbgSName(FHintControl),' Info.Control=',DbgSName(Info.Control));
|
|
if (FHintControl <> Info.Control) or (not (FHintTimerType in [ahtShowHint]))
|
|
then begin
|
|
if Info.ControlHasHint then
|
|
begin
|
|
FHintControl := Info.Control;
|
|
case FHintTimerType of
|
|
ahtNone,ahtShowHint:
|
|
StartHintTimer(HintPause,ahtShowHint);
|
|
ahtHideHint:
|
|
ShowHintWindow(Info);
|
|
else
|
|
HideHint;
|
|
end;
|
|
end else begin
|
|
HideHint;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.ShowHintWindow(const Info: THintInfoAtMouse);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.ShowHintWindow(const Info: THintInfoAtMouse);
|
|
|
|
function GetCursorHeightMargin: integer;
|
|
begin
|
|
Result:=25;
|
|
end;
|
|
|
|
var
|
|
ClientOrigin, ParentOrigin: TPoint;
|
|
HintInfo: THintInfo;
|
|
CanShow: Boolean;
|
|
HintWinRect: TRect;
|
|
CurHeight: Integer;
|
|
begin
|
|
if not FShowHint then exit;
|
|
if FHintControl=nil then exit;
|
|
|
|
//debugln('TApplication.ShowHintWindow A OldHint="',Hint,'" NewHint="',GetShortHint(Info.Control.Hint),'"');
|
|
Hint := GetShortHint(Info.Control.Hint);
|
|
|
|
CurHeight:=GetCursorHeightMargin;
|
|
HintInfo.HintControl := FHintControl;
|
|
HintInfo.HintPos := Info.MousePos;
|
|
|
|
// to reduce flicker
|
|
HintInfo.HintPos.X:=HintInfo.HintPos.X and (not $F);
|
|
HintInfo.HintPos.Y:=HintInfo.HintPos.Y and (not $F);
|
|
|
|
Inc(HintInfo.HintPos.Y, CurHeight);
|
|
HintInfo.HintMaxWidth := Screen.Width;
|
|
HintInfo.HintColor := FHintColor;
|
|
HintInfo.CursorRect := FHintControl.BoundsRect;
|
|
ClientOrigin := FHintControl.ClientOrigin;
|
|
ParentOrigin.X := 0;
|
|
ParentOrigin.Y := 0;
|
|
if FHintControl.Parent <> nil then
|
|
ParentOrigin := FHintControl.Parent.ClientOrigin;
|
|
OffsetRect(HintInfo.CursorRect, ParentOrigin.X - ClientOrigin.X,
|
|
ParentOrigin.Y - ClientOrigin.Y);
|
|
HintInfo.CursorPos := FHintControl.ScreenToClient(Info.MousePos);
|
|
HintInfo.HintStr := Hint;
|
|
HintInfo.ReshowTimeout := 0;
|
|
HintInfo.HideTimeout := FHintHidePause
|
|
+FHintHidePausePerChar*length(HintInfo.HintStr);
|
|
HintInfo.HintWindowClass := HintWindowClass;
|
|
HintInfo.HintData := nil;
|
|
CanShow := FHintControl.Perform(CM_HINTSHOW, 0, LParam(@HintInfo)) = 0;
|
|
if (HintInfo.HintWindowClass=nil)
|
|
or (not HintInfo.HintWindowClass.InheritsFrom(THintWindow)) then
|
|
HintInfo.HintWindowClass := HintWindowClass;
|
|
|
|
if CanShow and Assigned(FOnShowHint) then
|
|
FOnShowHint(HintInfo.HintStr, CanShow, HintInfo);
|
|
if CanShow and (FHintControl <> nil) and (HintInfo.HintStr <> '') then
|
|
begin
|
|
// create hint window
|
|
if (FHintWindow<>nil) and (FHintWindow.ClassType<>HintInfo.HintWindowClass)
|
|
then
|
|
FreeThenNil(FHintWindow);
|
|
if FHintWindow=nil then begin
|
|
FHintWindow:=THintWindowClass(HintInfo.HintWindowClass).Create(Self);
|
|
with FHintWindow do begin
|
|
Visible := False;
|
|
Caption := '';
|
|
AutoHide := False;
|
|
end;
|
|
end;
|
|
|
|
// make the hint have the same BiDiMode as the activating control
|
|
//FHintWindow.BiDiMode := FHintControl.BiDiMode;
|
|
// calculate the width of the hint based on HintStr and MaxWidth
|
|
with HintInfo do
|
|
HintWinRect := FHintWindow.CalcHintRect(HintMaxWidth, HintStr, HintData);
|
|
OffsetRect(HintWinRect, HintInfo.HintPos.X, HintInfo.HintPos.Y);
|
|
//DebugLn(['TApplication.ShowHintWindow HintStr="',HintInfo.HintStr,'" HintWinRect=',dbgs(HintWinRect)]);
|
|
{if FHintWindow.UseRightToLeftAlignment then
|
|
with HintWinRect do
|
|
begin
|
|
Dec(Left, FHintWindow.Canvas.TextWidth(HintInfo.HintStr) + 5);
|
|
Dec(Right, FHintWindow.Canvas.TextWidth(HintInfo.HintStr) + 5);
|
|
end;}
|
|
|
|
// Convert the client's rect to screen coordinates
|
|
{with HintInfo do
|
|
begin
|
|
FHintCursorRect.TopLeft :=
|
|
FHintControl.ClientToScreen(CursorRect.TopLeft);
|
|
FHintCursorRect.BottomRight :=
|
|
FHintControl.ClientToScreen(CursorRect.BottomRight);
|
|
end;}
|
|
|
|
FHintWindow.Color := HintInfo.HintColor;
|
|
//DebugLn(['TApplication.ShowHintWindow FHintWindow.Color=',dbgs(FHintWindow.Color),' HintInfo.HintColor=',dbgs(HintInfo.HintColor)]);
|
|
|
|
//debugln('TApplication.ShowHintWindow B HintWinRect=',dbgs(HintWinRect),' HintStr="',DbgStr(HintInfo.HintStr),'"');
|
|
FHintWindow.ActivateHint(HintWinRect,HintInfo.HintStr);
|
|
// start hide timer
|
|
StartHintTimer(HintHidePause,ahtHideHint);
|
|
end else
|
|
HideHint;
|
|
//DebugLn'TApplication.ShowHintWindow Info.ControlHasHint=',Info.ControlHasHint,' Type=',ord(FHintTimerType));
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.StartHintTimer(Interval: integer;
|
|
TimerType: TAppHintTimerType);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.StartHintTimer(Interval: integer;
|
|
TimerType: TAppHintTimerType);
|
|
begin
|
|
//debugln('TApplication.StartHintTimer ',dbgs(Interval));
|
|
StopHintTimer;
|
|
FHintTimerType:=TimerType;
|
|
if Interval>0 then begin
|
|
if FHintTimer=nil then
|
|
FHintTimer:=TCustomTimer.Create(Self);
|
|
FHintTimer.Interval:=Interval;
|
|
FHintTimer.OnTimer:=@OnHintTimer;
|
|
FHintTimer.Enabled:=true;
|
|
end else begin
|
|
OnHintTimer(Self);
|
|
end
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.OnHintTimer(Sender: TObject);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.OnHintTimer(Sender: TObject);
|
|
var
|
|
Info: THintInfoAtMouse;
|
|
OldHintTimerType: TAppHintTimerType;
|
|
begin
|
|
//DebugLn'TApplication.OnHintTimer Type=',ord(FHintTimerType));
|
|
OldHintTimerType:=FHintTimerType;
|
|
StopHintTimer;
|
|
case OldHintTimerType of
|
|
|
|
ahtShowHint:
|
|
begin
|
|
Info:=GetHintInfoAtMouse;
|
|
if Info.ControlHasHint then begin
|
|
ShowHintWindow(Info);
|
|
end else begin
|
|
HideHint;
|
|
end;
|
|
end;
|
|
|
|
else
|
|
CancelHint;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.UpdateVisible;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.UpdateVisible;
|
|
begin
|
|
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.DoIdleActions;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.DoIdleActions;
|
|
var
|
|
i: Integer;
|
|
CurForm: TCustomForm;
|
|
AForm: TForm;
|
|
begin
|
|
for i := 0 to Screen.CustomFormCount - 1 do begin
|
|
CurForm:=Screen.CustomForms[I];
|
|
if CurForm.HandleAllocated and CurForm.Visible and CurForm.Enabled then
|
|
CurForm.UpdateActions;
|
|
end;
|
|
if FFormList<>nil then begin
|
|
for i:=0 to FFormList.Count-1 do begin
|
|
AForm:=TForm(FFormList[i]);
|
|
if AForm.FormStyle=fsSplash then
|
|
AForm.Hide;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.MenuPopupHandler(Sender: TObject);
|
|
begin
|
|
HideHint;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.ProcessAsyncCallQueue
|
|
|
|
Call all methods queued to be called (QueueAsyncCall)
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.ProcessAsyncCallQueue;
|
|
var
|
|
lItem: PAsyncCallQueueItem;
|
|
begin
|
|
// take care: we may be called from within lItem^.Method
|
|
while FAsyncCallQueue <> nil do
|
|
begin
|
|
lItem := FAsyncCallQueue;
|
|
FAsyncCallQueue := lItem^.NextItem;
|
|
lItem^.Method(lItem^.Data);
|
|
Dispose(lItem);
|
|
end;
|
|
FAsyncCallQueueLast := nil;
|
|
end;
|
|
|
|
procedure TApplication.DoBeforeFinalization;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
if Self=nil then exit;
|
|
for i:=ComponentCount-1 downto 0 do begin
|
|
//debugln('TApplication.DoBeforeFinalization ',DbgSName(Components[i]));
|
|
if i<ComponentCount then Components[i].Free;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.IconChanged
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IconChanged(Sender: TObject);
|
|
begin
|
|
DebugLn('TApplication.IconChanged - TODO: convert this message...no implementation in gtk or win32');
|
|
// CNSendMessage(LM_SETFORMICON, Self, Pointer(GetIconHandle));
|
|
// NotifyForms(CM_ICONCHANGED);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.GetIconHandle
|
|
Returns: handle of default form icon
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.GetIconHandle: HICON;
|
|
begin
|
|
if FIcon<>nil then
|
|
Result := FIcon.Handle
|
|
else
|
|
Result:=0;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.GetTitle
|
|
Returns: title of application
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.GetTitle: string;
|
|
var
|
|
Ext: string;
|
|
begin
|
|
Result := inherited Title;
|
|
If Result = '' then begin
|
|
Result := ExtractFileName(GetExeName);
|
|
Ext := ExtractFileExt(Result);
|
|
If Ext <> '' then
|
|
Delete(Result, Length(Result) - Length(Ext) + 1, Length(Ext));
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.HandleException
|
|
Params: Sender
|
|
Returns: Nothing
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.HandleException(Sender: TObject);
|
|
|
|
begin
|
|
if Self=nil then exit;
|
|
if AppHandlingException in FFlags then begin
|
|
// there was an exception during showing the exception -> break the circle
|
|
DebugLn('TApplication.HandleException: ',
|
|
'there was another exception during showing the first exception');
|
|
HaltingProgram:=true;
|
|
DumpExceptionBackTrace;
|
|
Halt;
|
|
end;
|
|
Include(FFlags,AppHandlingException);
|
|
if StopOnException then
|
|
inherited Terminate;
|
|
if not (AppNoExceptionMessages in FFlags) then begin
|
|
// before we do anything, write it down
|
|
if ExceptObject is Exception then begin
|
|
DebugLn('TApplication.HandleException ',Exception(ExceptObject).Message);
|
|
end else begin
|
|
DebugLn('TApplication.HandleException Strange Exception ');
|
|
end;
|
|
DumpExceptionBackTrace;
|
|
end;
|
|
// release capture and hide all forms with stay on top, so that
|
|
// a message can be shown
|
|
if GetCapture <> 0 then SendMessage(GetCapture, LM_CANCELMODE, 0, 0);
|
|
HideAllFormsWithStayOnTop;
|
|
// handle the exception
|
|
if ExceptObject is Exception then begin
|
|
if not (ExceptObject is EAbort) then
|
|
if Assigned(OnException) then
|
|
OnException(Sender, Exception(ExceptObject))
|
|
else
|
|
ShowException(Exception(ExceptObject));
|
|
end else
|
|
SysUtils.ShowException(ExceptObject, ExceptAddr);
|
|
Exclude(FFlags,AppHandlingException);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.HandleMessage
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Handles all messages first then the Idle
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.HandleMessage;
|
|
begin
|
|
WidgetSet.AppProcessMessages; // process all events
|
|
if not Terminated then Idle(true);
|
|
end;
|
|
|
|
function TApplication.HelpContext(Sender: TObject; const Position: TPoint;
|
|
Context: THelpContext): Boolean;
|
|
begin
|
|
if ValidateHelpSystem then begin
|
|
Result := ShowHelpOrErrorForContext('',Context)=shrSuccess;
|
|
end else
|
|
Result := false;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.HelpContext(Context: THelpContext): Boolean;
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.HelpContext(Context: THelpContext): Boolean;
|
|
begin
|
|
Result:=HelpContext(nil,Point(0,0),Context);
|
|
end;
|
|
|
|
function TApplication.HelpKeyword(Sender: TObject; const Position: TPoint;
|
|
const Keyword: String): Boolean;
|
|
begin
|
|
if ValidateHelpSystem then begin
|
|
Result := ShowHelpOrErrorForKeyword('',Keyword)=shrSuccess;
|
|
end else
|
|
Result := false;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.HelpKeyword(const Keyword: String): Boolean;
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.HelpKeyword(const Keyword: String): Boolean;
|
|
begin
|
|
Result:=HelpKeyword(nil,Point(0,0),Keyword);
|
|
end;
|
|
|
|
procedure TApplication.ShowHelpForObjecct(Sender: TObject);
|
|
begin
|
|
if Sender is TControl then begin
|
|
TControl(Sender).ShowHelp;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.HideAllFormsWithStayOnTop;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.HideAllFormsWithStayOnTop;
|
|
var
|
|
i: Integer;
|
|
AForm: TCustomForm;
|
|
begin
|
|
if (Screen=nil) then exit;
|
|
for i:=0 to Screen.CustomFormCount-1 do begin
|
|
AForm:=Screen.CustomForms[i];
|
|
if AForm.FormStyle in fsAllStayOnTop then begin
|
|
//DebugLn('TApplication.HideAllFormsWithStayOnTop ',AForm.Name,':',AForm.ClassName);
|
|
AForm.Hide;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.IsWaiting: boolean;
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.IsWaiting: boolean;
|
|
begin
|
|
Result:=AppWaiting in FFlags;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.CancelHint;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.CancelHint;
|
|
begin
|
|
if FHintTimer<>nil then FHintTimer.Enabled:=false;
|
|
HideHint;
|
|
if FHintControl <> nil then
|
|
begin
|
|
FHintControl := nil;
|
|
//FHintActive := False;
|
|
//UnhookHintHooks;
|
|
//StopHintTimer;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.HideHint;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.HideHint;
|
|
begin
|
|
if FHintWindow<>nil then begin
|
|
FHintWindow.Visible:=false;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication Run
|
|
MainForm is loaded and control is passed to event processor.
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.Run;
|
|
begin
|
|
if (FMainForm <> nil) and FShowMainForm then FMainForm.Show;
|
|
WidgetSet.AppRun(@RunLoop);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication RunLoop
|
|
control is passed to event processor.
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.RunLoop;
|
|
|
|
procedure RunMessage;
|
|
begin
|
|
HandleMessage;
|
|
if Assigned(FMainForm) and (FMainForm.ModalResult = mrCancel)
|
|
then Terminate;
|
|
end;
|
|
|
|
begin
|
|
repeat
|
|
if CaptureExceptions then begin
|
|
// run with try..except
|
|
try
|
|
RunMessage;
|
|
except
|
|
on E: Exception do HandleException(E);
|
|
end;
|
|
end else begin
|
|
// run without try..except
|
|
RunMessage;
|
|
end;
|
|
until Terminated;
|
|
end;
|
|
|
|
procedure TApplication.Activate;
|
|
begin
|
|
if AppActive in FFlags then exit;
|
|
Include(FFlags,AppActive);
|
|
NotifyActivateHandler;
|
|
end;
|
|
|
|
procedure TApplication.Deactivate;
|
|
begin
|
|
if (not (AppActive in FFlags)) then exit;
|
|
if (FindControl(GetFocus)<>nil) then begin
|
|
// another control of this application has got the focus
|
|
exit;
|
|
end;
|
|
Exclude(FFlags,AppActive);
|
|
NotifyDeactivateHandler;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------}
|
|
{ TApplication WndPRoc }
|
|
{ }
|
|
{------------------------------------------------------------------------------}
|
|
procedure TApplication.WndProc(var AMessage : TLMessage);
|
|
begin
|
|
case AMessage.Msg of
|
|
CM_ACTIONEXECUTE, CM_ACTIONUPDATE: AMessage.Result := LResult(DispatchAction(AMessage.Msg, TBasicAction(AMessage.LParam)));
|
|
else
|
|
Dispatch(AMessage);
|
|
end;
|
|
end;
|
|
|
|
function TApplication.DispatchAction(Msg: Longint; Action: TBasicAction
|
|
): Boolean;
|
|
var
|
|
Form: TCustomForm;
|
|
begin
|
|
Result:=false;
|
|
Form := Screen.ActiveForm;
|
|
if (Form<>nil) and (Form.Perform(Msg, 0, PtrInt(Action)) = 1) then
|
|
Result:=true
|
|
else if (MainForm<>Form) and (MainForm<>nil)
|
|
and (MainForm.Perform(Msg, 0, PtrInt(Action)) = 1)
|
|
then
|
|
Result:=true;
|
|
// Disable action if no "user" handler is available
|
|
if (not Result) and (Action is TCustomAction)
|
|
and TCustomAction(Action).Enabled
|
|
and TCustomAction(Action).DisableIfNoHandler then
|
|
TCustomAction(Action).Enabled := Assigned(Action.OnExecute);
|
|
end;
|
|
|
|
procedure TApplication.AddHandler(HandlerType: TApplicationHandlerType;
|
|
const Handler: TMethod; AsLast: Boolean);
|
|
begin
|
|
if Handler.Code=nil then RaiseGDBException('TApplication.AddHandler');
|
|
if FApplicationHandlers[HandlerType]=nil then
|
|
FApplicationHandlers[HandlerType]:=TMethodList.Create;
|
|
FApplicationHandlers[HandlerType].Add(Handler,AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveHandler(HandlerType: TApplicationHandlerType;
|
|
const Handler: TMethod);
|
|
begin
|
|
FApplicationHandlers[HandlerType].Remove(Handler);
|
|
end;
|
|
|
|
function TApplication.GetConsoleApplication: boolean;
|
|
begin
|
|
Result:=false;
|
|
end;
|
|
|
|
procedure TApplication.SetHint(const AValue: string);
|
|
begin
|
|
if FHint=AValue then exit;
|
|
FHint:=AValue;
|
|
if Assigned(FOnHint) then
|
|
FOnHint(Self)
|
|
else begin
|
|
// Send THintAction
|
|
with TCustomHintAction.Create(Self) do begin
|
|
Hint := FHint;
|
|
try
|
|
Execute;
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.SetHintColor(const AValue: TColor);
|
|
begin
|
|
if FHintColor=AValue then exit;
|
|
FHintColor:=AValue;
|
|
if FHintWindow <> nil then
|
|
FHintWindow.Color := FHintColor;
|
|
end;
|
|
|
|
procedure TApplication.DoOnIdleEnd;
|
|
begin
|
|
if (AppIdleEndSent in FFlags) then exit;
|
|
if Assigned(OnIdleEnd) then OnIdleEnd(Self);
|
|
NotifyIdleEndHandler;
|
|
Include(FFlags,AppIdleEndSent);
|
|
end;
|
|
|
|
function TApplication.GetActive: boolean;
|
|
begin
|
|
Result := AppActive in Flags;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.GetCurrentHelpFile: string;
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.GetCurrentHelpFile: string;
|
|
var
|
|
ActiveForm: TCustomForm;
|
|
begin
|
|
ActiveForm := Screen.ActiveCustomForm;
|
|
if Assigned(ActiveForm) and (ActiveForm.FHelpFile <> '') then
|
|
Result := ActiveForm.HelpFile
|
|
else
|
|
Result := HelpFile;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication ShowException
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.ShowException(E: Exception);
|
|
var
|
|
Msg: string;
|
|
MsgResult: Integer;
|
|
begin
|
|
if AppNoExceptionMessages in FFlags then exit;
|
|
Msg := E.Message;
|
|
if (Msg <> '') and (Msg[length(Msg)] <> '.') then Msg := Msg + '.';
|
|
if (not Terminated)
|
|
and (Self<>nil) then begin
|
|
DisableIdleHandler;
|
|
try
|
|
MsgResult:=MessageBox(PChar(Format(
|
|
rsPressOkToIgnoreAndRiskDataCorruptionPressCancelToK, [Msg, #13#13, #13]
|
|
)), PChar(GetTitle),
|
|
MB_OKCANCEL + MB_ICONERROR);
|
|
finally
|
|
EnableIdleHandler;
|
|
end;
|
|
if MsgResult<>mrOk then begin
|
|
Include(FFlags,AppNoExceptionMessages);
|
|
HaltingProgram:=true;
|
|
Halt;
|
|
end;
|
|
end else
|
|
inherited ShowException(E);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication Terminate
|
|
Class is terminated and the component engine is shutdown
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.Terminate;
|
|
begin
|
|
inherited Terminate;
|
|
WidgetSet.AppTerminate;
|
|
end;
|
|
|
|
procedure TApplication.DisableIdleHandler;
|
|
begin
|
|
inc(FIdleLockCount);
|
|
end;
|
|
|
|
procedure TApplication.EnableIdleHandler;
|
|
begin
|
|
if FIdleLockCount<=0 then
|
|
RaiseGDBException('TApplication.EnableIdleHandler');
|
|
dec(FIdleLockCount);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.NotifyUserInputHandler;
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.NotifyUserInputHandler(Msg: Cardinal);
|
|
var
|
|
i: integer;
|
|
begin
|
|
FLastMouseControlValid:=false;
|
|
case Msg of
|
|
LM_MOUSEMOVE: DoOnMouseMove;
|
|
else CancelHint;
|
|
end;
|
|
|
|
if Assigned(FOnUserInput) then FOnUserInput(Self, Msg);
|
|
|
|
i:=FApplicationHandlers[ahtUserInput].Count;
|
|
while FApplicationHandlers[ahtUserInput].NextDownIndex(i) do
|
|
TOnUserInputEvent(FApplicationHandlers[ahtUserInput][i])(Self,Msg);
|
|
end;
|
|
|
|
procedure TApplication.NotifyKeyDownBeforeHandler(Sender: TObject;
|
|
var Key: Word; Shift: TShiftState);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i:=FApplicationHandlers[ahtKeyDownBefore].Count;
|
|
while FApplicationHandlers[ahtKeyDownBefore].NextDownIndex(i) do
|
|
TKeyEvent(FApplicationHandlers[ahtKeyDownBefore][i])(Sender,Key,Shift);
|
|
end;
|
|
|
|
procedure TApplication.NotifyKeyDownHandler(Sender: TObject;
|
|
var Key: Word; Shift: TShiftState);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i:=FApplicationHandlers[ahtKeyDownAfter].Count;
|
|
while FApplicationHandlers[ahtKeyDownAfter].NextDownIndex(i) do
|
|
TKeyEvent(FApplicationHandlers[ahtKeyDownAfter][i])(Sender,Key,Shift);
|
|
if (Shift=[]) and (Key=VK_F1) then
|
|
ShowHelpForObjecct(Sender);
|
|
end;
|
|
|
|
procedure TApplication.ControlKeyDown(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
var
|
|
AControl: TWinControl;
|
|
begin
|
|
if Sender is TWinControl then begin
|
|
AControl:=TWinControl(Sender);
|
|
if AControl=nil then ;
|
|
//debugln('TApplication.ControlKeyDown A ',DbgSName(AControl));
|
|
FLastKeyDownSender:=AControl;
|
|
|
|
// handle navigation key
|
|
DoTabKey(AControl, Key, Shift);
|
|
end else
|
|
FLastKeyDownSender:=nil;
|
|
//DebugLn(['TApplication.ControlKeyDown Sender=',DbgSName(Sender),' Key=',Key,' Shift=',dbgs(Shift)]);
|
|
FLastKeyDownKey:=Key;
|
|
FLastKeyDownShift:=Shift;
|
|
end;
|
|
|
|
procedure TApplication.ControlKeyUp(Sender: TObject; var Key: Word;
|
|
Shift: TShiftState);
|
|
var
|
|
AControl: TWinControl;
|
|
begin
|
|
if Key=VK_UNKNOWN then exit;
|
|
|
|
if Sender is TWinControl then begin
|
|
AControl:=TWinControl(Sender);
|
|
//debugln('TApplication.ControlKeyUp A ',DbgSName(AControl),' Key=',dbgs(Key),' Shift=',dbgs(Shift));
|
|
if FLastKeyDownKey=VK_UNKNOWN then begin
|
|
// key was already handled in key down
|
|
//debugln('TApplication.ControlKeyUp key was handled in key down');
|
|
exit;
|
|
end;
|
|
if (Key<>FLastKeyDownKey) or (Shift<>FLastKeyDownShift)
|
|
or (AControl<>FLastKeyDownSender) then begin
|
|
// a key up, without key down
|
|
//debugln('TApplication.ControlKeyUp key was handled in key down or in key up');
|
|
exit;
|
|
end;
|
|
|
|
// handle special navigation keys
|
|
DoReturnKey(AControl, Key, Shift);
|
|
DoEscapeKey(AControl, Key, Shift);
|
|
end;
|
|
FLastKeyDownKey := VK_UNKNOWN;
|
|
end;
|
|
|
|
procedure TApplication.AddOnIdleHandler(Handler: TIdleEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtIdle,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnIdleHandler(Handler: TIdleEvent);
|
|
begin
|
|
RemoveHandler(ahtIdle,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnIdleEndHandler(Handler: TNotifyEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtIdleEnd,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnIdleEndHandler(Handler: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(ahtIdleEnd,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnUserInputHandler(Handler: TOnUserInputEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtUserInput,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnUserInputHandler(Handler: TOnUserInputEvent);
|
|
begin
|
|
RemoveHandler(ahtUserInput,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnKeyDownBeforeHandler(Handler: TKeyEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtKeyDownBefore,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnKeyDownBeforeHandler(Handler: TKeyEvent);
|
|
begin
|
|
RemoveHandler(ahtKeyDownBefore,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnKeyDownHandler(Handler: TKeyEvent; AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtKeyDownAfter,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnKeyDownHandler(Handler: TKeyEvent);
|
|
begin
|
|
RemoveHandler(ahtKeyDownAfter,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnActivateHandler(Handler: TNotifyEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtActivate,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnActivateHandler(Handler: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(ahtActivate,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnDeactivateHandler(Handler: TNotifyEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtDeactivate,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnDeactivateHandler(Handler: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(ahtDeactivate,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.RemoveAllHandlersOfObject(AnObject: TObject);
|
|
var
|
|
HandlerType: TApplicationHandlerType;
|
|
begin
|
|
for HandlerType:=Low(TApplicationHandlerType) to High(TApplicationHandlerType)
|
|
do
|
|
FApplicationHandlers[HandlerType].RemoveAllMethodsOfObject(AnObject);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.IntfEndSession;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfEndSession;
|
|
begin
|
|
if Assigned(FOnEndSession) then FOnEndSession(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.IntfQueryEndSession(var Cancel : Boolean);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfQueryEndSession(var Cancel : Boolean);
|
|
begin
|
|
if Assigned(FOnQueryEndSession) then FOnQueryEndSession(Cancel);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.IntfAppMinimize;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfAppMinimize;
|
|
begin
|
|
if Assigned(FOnMinimize) then FOnMinimize(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.IntfAppRestore;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfAppRestore;
|
|
begin
|
|
if Assigned(FOnRestore) then FOnRestore(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.IntfFilesDrop
|
|
Params: FileNames - Dropped files
|
|
|
|
Invokes OnFilesDropEvent of the application.
|
|
This function is called by the interface.
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfFilesDrop(const FileNames: array of String);
|
|
begin
|
|
if Assigned(FOnFilesDrop) then FOnFilesDrop(Self, FileNames);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.DoBeforeMouseMessage(CurMouseControl: TControl);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.DoBeforeMouseMessage(CurMouseControl: TControl);
|
|
begin
|
|
//debugln(['TApplication.DoBeforeMouseMessage ',DbgSName(CurMouseControl)]);
|
|
UpdateMouseControl(GetControlAtMouse);
|
|
end;
|
|
|
|
function TApplication.IsShortcut(var Message: TLMKey): boolean;
|
|
var
|
|
ModalForm: TCustomForm;
|
|
begin
|
|
Result := false;
|
|
if Assigned(FOnShortcut) then
|
|
begin
|
|
FOnShortcut(Message, Result);
|
|
if Result then
|
|
exit;
|
|
end;
|
|
|
|
// next: if there is a modal form, let it handle the short cut
|
|
ModalForm:=Screen.GetCurrentModalForm;
|
|
if ModalForm<>nil then begin
|
|
Result := ModalForm.IsShortcut(Message);
|
|
end else begin
|
|
// there is no modal form
|
|
|
|
// let the current focused form handle the shortcut
|
|
if Screen.ActiveCustomForm<>nil then begin
|
|
Result := Screen.ActiveCustomForm.IsShortcut(Message);
|
|
if Result then exit;
|
|
end;
|
|
|
|
// let the main form handle the shortcut
|
|
if (MainForm<>nil) and (Screen.ActiveCustomForm<>MainForm) then begin
|
|
Result := FMainForm.IsShortcut(Message);
|
|
if Result then exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.DoEscapeKey(AControl: TWinControl; var Key: Word;
|
|
Shift: TShiftState);
|
|
var
|
|
Form: TCustomForm;
|
|
begin
|
|
if (Shift = []) and (Key = VK_ESCAPE) then begin
|
|
Form := GetParentForm(AControl);
|
|
if Form<>nil then begin
|
|
if (anoEscapeForCancelControl in Navigation) then begin
|
|
if (Form.CancelControl <> nil) then
|
|
begin
|
|
//debugln('TApplication.ControlKeyUp VK_ESCAPE ', Acontrol.Name);
|
|
Form.CancelControl.ExecuteCancelAction;
|
|
Key := VK_UNKNOWN;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.DoReturnKey(AControl: TWinControl; var Key: Word;
|
|
Shift: TShiftState);
|
|
var
|
|
Form: TCustomForm;
|
|
lDefaultControl: TControl;
|
|
begin
|
|
if (Shift = []) and (Key = VK_RETURN) then begin
|
|
//DebugLn(['TApplication.DoReturnKey ',DbgSName(AControl)]);
|
|
Form := GetParentForm(AControl);
|
|
if Form<>nil then begin
|
|
if anoReturnForDefaultControl in Navigation then
|
|
begin
|
|
lDefaultControl := Form.ActiveDefaultControl;
|
|
if lDefaultControl = nil then
|
|
lDefaultControl := Form.DefaultControl;
|
|
if (lDefaultControl <> nil)
|
|
and ((lDefaultControl.Parent = nil) or (lDefaultControl.Parent.CanFocus))
|
|
and lDefaultControl.Enabled and lDefaultControl.Visible then
|
|
begin
|
|
//debugln('TApplication.ControlKeyUp VK_RETURN ', Acontrol.Name);
|
|
lDefaultControl.ExecuteDefaultAction;
|
|
Key := VK_UNKNOWN;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.DoTabKey(AControl: TWinControl; var Key: Word;
|
|
Shift: TShiftState);
|
|
begin
|
|
if (Key=VK_Tab) and ((Shift-[ssShift])=[])
|
|
and (anoTabToSelectNext in Navigation)
|
|
and AControl.Focused then
|
|
begin
|
|
Key:=VK_UNKNOWN;
|
|
AControl.PerformTab(not (ssShift in Shift));
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
TApplication CreateForm
|
|
|
|
Note: The name is confusing and only kept for Delphi compatibility. It can
|
|
create any kind of components.
|
|
|
|
Create a Component instance and sets the pointer to the component variable
|
|
and loads the component. If it is a form it will be added to the applications
|
|
forms list
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.CreateForm(InstanceClass: TComponentClass;
|
|
out Reference);
|
|
var
|
|
Instance: TComponent;
|
|
ok: boolean;
|
|
AForm: TForm;
|
|
begin
|
|
// Allocate the instance, without calling the constructor
|
|
Instance := TComponent(InstanceClass.NewInstance);
|
|
// set the Reference before the constructor is called, so that
|
|
// events and constructors can refer to it
|
|
TComponent(Reference) := Instance;
|
|
|
|
ok:=false;
|
|
try
|
|
if (FCreatingForm=nil) and (Instance is TForm) then
|
|
FCreatingForm:=TForm(Instance);
|
|
Instance.Create(Self);
|
|
ok:=true;
|
|
finally
|
|
if not ok then begin
|
|
TComponent(Reference) := nil;
|
|
if FCreatingForm=Instance then
|
|
FCreatingForm:=nil;
|
|
end;
|
|
end;
|
|
|
|
if (Instance is TForm) then begin
|
|
AForm:=TForm(Instance);
|
|
UpdateMainForm(AForm);
|
|
if FMainForm = AForm then
|
|
AForm.HandleNeeded;
|
|
if not Assigned(FFormList) then
|
|
FFormList := TList.Create;
|
|
FFormList.Add(AForm);
|
|
if AForm.FormStyle=fsSplash then begin
|
|
// show the splash form and handle the paint message
|
|
AForm.Show;
|
|
AForm.Paint;
|
|
ProcessMessages;
|
|
end;
|
|
end;
|
|
{$IFDEF AfterConstructionDataModuleNotWorking}
|
|
if (Instance is TDataModule) then begin
|
|
TDataModule(instance).AfterConstruction;
|
|
end;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TApplication.UpdateMainForm(AForm: TForm);
|
|
begin
|
|
if (FMainForm = nil)
|
|
and (FCreatingForm=AForm)
|
|
and (not (AppDestroying in FFlags))
|
|
and not (AForm.FormStyle in [fsMDIChild, fsSplash])
|
|
then
|
|
FMainForm := AForm;
|
|
end;
|
|
|
|
procedure TApplication.QueueAsyncCall(const AMethod: TDataEvent; Data: PtrInt);
|
|
var
|
|
lItem: PAsyncCallQueueItem;
|
|
begin
|
|
if AppDoNotCallAsyncQueue in FFlags then
|
|
raise Exception.Create('TApplication.QueueAsyncCall already shut down');
|
|
New(lItem);
|
|
lItem^.Method := AMethod;
|
|
lItem^.Data := Data;
|
|
lItem^.NextItem := nil;
|
|
if FAsyncCallQueue = nil then
|
|
FAsyncCallQueue := lItem
|
|
else
|
|
FAsyncCallQueueLast^.NextItem := lItem;
|
|
FAsyncCallQueueLast := lItem;
|
|
end;
|
|
|
|
procedure TApplication.FreeComponent(Data: PtrInt);
|
|
var
|
|
OldComponents: TAvgLvlTree;
|
|
begin
|
|
TComponent(Data).Free;
|
|
if FComponentsToRelease<>nil then begin
|
|
OldComponents:=FComponentsToRelease;
|
|
FComponentsToRelease:=nil;
|
|
OldComponents.FreeAndClear;
|
|
OldComponents.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.ReleaseComponent(AComponent: TComponent);
|
|
var
|
|
IsFirstItem: Boolean;
|
|
begin
|
|
if csDestroying in AComponent.ComponentState then exit;
|
|
if AppDestroying in FFlags then begin
|
|
// free immediately
|
|
AComponent.Free;
|
|
end else begin
|
|
// free later
|
|
// => add to the FComponentsToRelease
|
|
IsFirstItem:=FComponentsToRelease=nil;
|
|
if IsFirstItem then
|
|
FComponentsToRelease:=TAvgLvlTree.Create(@ComparePointers)
|
|
else if FComponentsToRelease.Find(AComponent)<>nil then
|
|
exit;
|
|
FComponentsToRelease.Add(AComponent);
|
|
AComponent.FreeNotification(Self);
|
|
if IsFirstItem then
|
|
QueueAsyncCall(@FreeComponent, 0);
|
|
end;
|
|
end;
|
|
|
|
function TApplication.ExecuteAction(ExeAction: TBasicAction): Boolean;
|
|
begin
|
|
Result := False;
|
|
if Assigned(FOnActionExecute) then FOnActionExecute(ExeAction, Result);
|
|
end;
|
|
|
|
function TApplication.UpdateAction(TheAction: TBasicAction): Boolean;
|
|
begin
|
|
Result := False;
|
|
if Assigned(FOnActionUpdate) then FOnActionUpdate(TheAction,Result);
|
|
end;
|