mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-21 18:23:34 +02:00
2104 lines
64 KiB
PHP
2104 lines
64 KiB
PHP
{%MainUnit ../forms.pp}
|
|
{******************************************************************************
|
|
TApplication
|
|
******************************************************************************
|
|
|
|
*****************************************************************************
|
|
* *
|
|
* This file is part of the Lazarus Component Library (LCL) *
|
|
* *
|
|
* See the file COPYING.modifiedLGPL.txt, 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. *
|
|
* *
|
|
*****************************************************************************
|
|
}
|
|
|
|
{ $define DebugHintWindow}
|
|
|
|
function FindApplicationComponent(const ComponentName: string): TComponent;
|
|
begin
|
|
if Application.FindGlobalComponentEnabled then
|
|
begin
|
|
Result:=Application.FindComponent(ComponentName);
|
|
if Result=nil then
|
|
Result:=Screen.FindForm(ComponentName);
|
|
if Result=nil then
|
|
Result:=Screen.FindDataModule(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) 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(FindControlAtPosition(Result.MousePos, True));
|
|
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);
|
|
const
|
|
BidiModeMap: array[Boolean] of TBiDiMode = (bdLeftToRight, bdRightToLeft);
|
|
|
|
function IsRTLLang(ALang: String): Boolean;
|
|
begin
|
|
Result := (ALang = 'ar') or
|
|
(ALang = 'he');
|
|
end;
|
|
|
|
var
|
|
LangDefault, LangFallback: String;
|
|
begin
|
|
LCLProc.SendApplicationMessageFunction:=@SendApplicationMsg;
|
|
|
|
FShowButtonGlyphs := sbgAlways;
|
|
FShowMenuGlyphs := sbgAlways;
|
|
FMainForm := nil;
|
|
FMouseControl := nil;
|
|
FHintColor := DefHintColor;
|
|
FHintPause := DefHintPause;
|
|
FHintShortCuts := True;
|
|
FHintShortPause := DefHintShortPause;
|
|
FHintHidePause := DefHintHidePause;
|
|
FHintHidePausePerChar := DefHintHidePausePerChar;
|
|
FShowHint := true;
|
|
FShowMainForm := true;
|
|
FFormList := nil;
|
|
FRestoreStayOnTop := nil;
|
|
FOnIdle := nil;
|
|
FIcon := TIcon.Create;
|
|
FIcon.OnChange := @IconChanged;
|
|
FNavigation := [anoTabToSelectNext,anoReturnForDefaultControl,
|
|
anoEscapeForCancelControl,anoF1ForHelp,anoArrowToSelectNextInParent];
|
|
ApplicationActionComponent:=Self;
|
|
OnMenuPopupHandler:=@MenuPopupHandler;
|
|
|
|
FFindGlobalComponentEnabled:=true;
|
|
RegisterFindGlobalComponentProc(@FindApplicationComponent);
|
|
|
|
{$ifndef wince}// remove ifdef when gettext is fixed
|
|
LCLGetLanguageIDs(LangDefault, LangFallback);
|
|
if LangDefault <> '' then
|
|
FBidiMode := BidiModeMap[IsRTLLang(LangDefault)]
|
|
else
|
|
FBidiMode := BidiModeMap[IsRTLLang(LangFallback)];
|
|
{$else}
|
|
FBidiMode := bdLeftToRight;
|
|
{$endif}
|
|
|
|
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);
|
|
FreeIconHandles;
|
|
FreeThenNil(FFormList);
|
|
FreeThenNil(FRestoreStayOnTop);
|
|
|
|
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 := ParamStrUTF8(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
|
|
ReleaseComponents;
|
|
ProcessAsyncCallQueue;
|
|
UpdateMouseHint(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 (WidgetSet.ClassType = TWidgetSet)
|
|
then begin
|
|
DebugLn('ERROR: ',rsNoWidgetSet);
|
|
raise Exception.Create(rsNoWidgetSet);
|
|
end;
|
|
WidgetSet.AppInit(ScreenInfo);
|
|
ScreenInfo.Initialized := True;
|
|
Screen.UpdateScreen;
|
|
// set that we are initialized => all exceptions will be handled by our HandleException
|
|
include(FFlags, AppInitialized);
|
|
|
|
// application icon
|
|
if LazarusResources.Find('MAINICON') <> nil then
|
|
Icon.LoadFromLazarusResource('MAINICON');
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.UpdateMouseHint
|
|
Params: None
|
|
Returns: Nothing
|
|
|
|
Handles mouse Idle
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.UpdateMouseHint(CurrentControl: TControl);
|
|
var
|
|
HintControl: TControl;
|
|
begin
|
|
HintControl := GetHintControl(CurrentControl);
|
|
if HintControl = nil then
|
|
Hint := ''
|
|
else
|
|
Hint := GetLongHint(HintControl.Hint);
|
|
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.HelpCommand(Command: Word; Data: PtrInt): Boolean;
|
|
var
|
|
CallHelp: Boolean;
|
|
begin
|
|
CallHelp := True;
|
|
|
|
Result := DoOnHelp(Command, Data, CallHelp);
|
|
|
|
if Result then
|
|
Exit;
|
|
|
|
if CallHelp then
|
|
begin
|
|
// TODO: call help
|
|
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.SetBidiMode ( const AValue : TBiDiMode ) ;
|
|
begin
|
|
if AValue <> FBidiMode then
|
|
FBidiMode := AValue;
|
|
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.SetShowButtonGlyphs(const AValue: TApplicationShowGlyphs);
|
|
begin
|
|
if FShowButtonGlyphs = AValue then
|
|
Exit;
|
|
FShowButtonGlyphs := AValue;
|
|
NotifyCustomForms(CM_APPSHOWBTNGLYPHCHANGED);
|
|
end;
|
|
|
|
procedure TApplication.SetShowMenuGlyphs(const AValue: TApplicationShowGlyphs);
|
|
begin
|
|
if FShowMenuGlyphs = AValue then
|
|
Exit;
|
|
FShowMenuGlyphs := AValue;
|
|
NotifyCustomForms(CM_APPSHOWMENUGLYPHCHANGED);
|
|
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;
|
|
|
|
Application.UpdateMouseHint(FMouseControl);
|
|
|
|
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
|
|
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;
|
|
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;
|
|
|
|
procedure TApplication.NotifyCustomForms(Msg: Word);
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to Screen.CustomFormCount - 1 do
|
|
Screen.CustomForms[i].Perform(Msg, 0, 0);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.IsHintMsg(var Msg: TMsg): Boolean;
|
|
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.IsHintMsg(var Msg: TMsg): Boolean;
|
|
begin
|
|
Result := False;
|
|
end;
|
|
|
|
function TApplication.DoOnHelp(Command: Word; Data: PtrInt; var CallHelp: Boolean): Boolean;
|
|
var
|
|
ActiveForm: TCustomForm;
|
|
i: LongInt;
|
|
begin
|
|
ActiveForm := Screen.ActiveCustomForm;
|
|
|
|
if Assigned(ActiveForm) and Assigned(ActiveForm.FOnHelp) then
|
|
Result := ActiveForm.FOnHelp(Command, Data, CallHelp)
|
|
else
|
|
begin
|
|
if Assigned(FOnHelp) then
|
|
Result := FOnHelp(Command, Data, CallHelp)
|
|
else
|
|
Result := False;
|
|
i := FApplicationHandlers[ahtHelp].Count;
|
|
while not Result and FApplicationHandlers[ahtHelp].NextDownIndex(i) do
|
|
Result := THelpEvent(FApplicationHandlers[ahtHelp][i])(Command, Data, CallHelp);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.DoOnMouseMove;
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.DoOnMouseMove;
|
|
var
|
|
Info: THintInfoAtMouse;
|
|
HintControlChanged: Boolean;
|
|
begin
|
|
Info := GetHintInfoAtMouse;
|
|
|
|
{$ifdef DebugHintWindow}
|
|
DebugLn('TApplication.DoOnMouseMove Info.ControlHasHint=',dbgs(Info.ControlHasHint),' Type=',dbgs(ord(FHintTimerType)),' FHintControl=',DbgSName(FHintControl),' Info.Control=',DbgSName(Info.Control));
|
|
{$endif}
|
|
HintControlChanged := FHintControl <> Info.Control;
|
|
if Info.ControlHasHint then
|
|
begin
|
|
if HintControlChanged then
|
|
begin
|
|
StopHintTimer;
|
|
HideHint;
|
|
FHintControl := Info.Control;
|
|
FHintRect := FHintControl.BoundsRect;
|
|
end;
|
|
case FHintTimerType of
|
|
ahttNone, ahttHideHint:
|
|
//react only if the hint control changed or if the mouse leave the previously set hint rect
|
|
if HintControlChanged or (not PtInRect(FHintRect, FHintControl.ScreenToClient(Info.MousePos))) then
|
|
begin
|
|
//if a hint is visible immediately query the app to show a new hint...
|
|
if FHintTimerType = ahttHideHint then
|
|
ShowHintWindow(Info);
|
|
//...if there's no hint window visible at this point than schedule a new query
|
|
if (FHintTimerType = ahttNone) or (FHintWindow = nil) or not FHintWindow.Visible then
|
|
StartHintTimer(HintPause, ahttShowHint);
|
|
end;
|
|
ahttShowHint:
|
|
StartHintTimer(HintPause, ahttShowHint);
|
|
end;
|
|
end
|
|
else
|
|
CancelHint;
|
|
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;
|
|
i: LongInt;
|
|
begin
|
|
if not FShowHint or (FHintControl=nil) then
|
|
Exit;
|
|
|
|
{$ifdef DebugHintWindow}
|
|
debugln('TApplication.ShowHintWindow A OldHint="',Hint,'" NewHint="',GetShortHint(Info.Control.Hint),'"');
|
|
{$endif}
|
|
|
|
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 := GetShortHint(Info.Control.Hint);
|
|
HintInfo.ReshowTimeout := 0;
|
|
HintInfo.HideTimeout := FHintHidePause
|
|
+FHintHidePausePerChar*length(HintInfo.HintStr);
|
|
HintInfo.HintWindowClass := HintWindowClass;
|
|
HintInfo.HintData := nil;
|
|
CanShow := FHintControl.Perform(CM_HINTSHOW, 0, LParam(PtrUInt(@HintInfo))) = 0;
|
|
if (HintInfo.HintWindowClass=nil)
|
|
or (not HintInfo.HintWindowClass.InheritsFrom(THintWindow)) then
|
|
HintInfo.HintWindowClass := HintWindowClass;
|
|
|
|
i:=FApplicationHandlers[ahtShowHint].Count;
|
|
if CanShow and (i>0) then begin
|
|
if Assigned(FOnShowHint) then
|
|
FOnShowHint(HintInfo.HintStr, CanShow, HintInfo);
|
|
while FApplicationHandlers[ahtShowHint].NextDownIndex(i) do
|
|
TShowHintEvent(FApplicationHandlers[ahtShowHint][i])(HintInfo.HintStr, CanShow, HintInfo);
|
|
end;
|
|
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);
|
|
FHintRect := HintInfo.CursorRect;
|
|
// start hide timer
|
|
StartHintTimer(HintInfo.HideTimeout,ahttHideHint);
|
|
end
|
|
else
|
|
HideHint;
|
|
|
|
{$ifdef DebugHintWindow}
|
|
DebugLn(['TApplication.ShowHintWindow Info.ControlHasHint=',
|
|
Info.ControlHasHint, ' Type=', ord(FHintTimerType)]);
|
|
{$endif}
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.StartHintTimer(Interval: integer;
|
|
TimerType: TAppHintTimerType);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.StartHintTimer(Interval: integer;
|
|
TimerType: TAppHintTimerType);
|
|
begin
|
|
{$ifdef DebugHintWindow}
|
|
debugln('TApplication.StartHintTimer ',dbgs(Interval));
|
|
{$endif}
|
|
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
|
|
OnHintTimer(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.OnHintTimer(Sender: TObject);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.OnHintTimer(Sender: TObject);
|
|
var
|
|
Info: THintInfoAtMouse;
|
|
begin
|
|
{$ifdef DebugHintWindow}
|
|
DebugLn('TApplication.OnHintTimer Type=', IntToStr(ord(FHintTimerType)));
|
|
{$endif}
|
|
StopHintTimer;
|
|
case FHintTimerType of
|
|
ahttShowHint:
|
|
begin
|
|
Info := GetHintInfoAtMouse;
|
|
if Info.ControlHasHint then
|
|
ShowHintWindow(Info)
|
|
else
|
|
HideHint;
|
|
end;
|
|
ahttHideHint:
|
|
begin
|
|
HideHint;
|
|
FHintTimerType := ahttNone;
|
|
end
|
|
else
|
|
HideHint;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.UpdateVisible;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.UpdateVisible;
|
|
|
|
function UseAppTaskbarItem(AForm: TCustomForm): Boolean; inline;
|
|
begin
|
|
Result := (AForm = MainForm) or (AForm.ShowInTaskBar in [stNever, stDefault]);
|
|
end;
|
|
|
|
function HasVisibleForms: Boolean;
|
|
var
|
|
i: integer;
|
|
AForm: TCustomForm;
|
|
begin
|
|
Result := False;
|
|
// how to count correct? Do we need to count TCustomForms exclude THintWindow
|
|
// or just count TForm descendants?
|
|
for i := 0 to Screen.FormCount - 1 do
|
|
begin
|
|
AForm := Screen.Forms[i];
|
|
if AForm.Visible and (AForm.Parent = nil) and UseAppTaskbarItem(AForm) then
|
|
begin
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
begin
|
|
// if there are visible forms wich shares application taskbar item then application
|
|
// task bar item must be visible too else hide it
|
|
WidgetSet.AppSetVisible(HasVisibleForms);
|
|
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;
|
|
Event: TDataEvent;
|
|
Data: PtrInt;
|
|
begin
|
|
// take care: we may be called from within lItem^.Method
|
|
while FAsyncCallQueue <> nil do
|
|
begin
|
|
lItem := FAsyncCallQueue;
|
|
FAsyncCallQueue := lItem^.NextItem;
|
|
Event:=lItem^.Method;
|
|
Data:=lItem^.Data;
|
|
Dispose(lItem);
|
|
Event(Data);
|
|
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;
|
|
|
|
function TApplication.GetParams(Index: Integer): string;
|
|
begin
|
|
Result:=ParamStrUTF8(Index);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.IconChanged
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IconChanged(Sender: TObject);
|
|
var
|
|
i: integer;
|
|
begin
|
|
FreeIconHandles;
|
|
Widgetset.AppSetIcon(SmallIconHandle, BigIconHandle);
|
|
if FFormList <> nil then
|
|
for i := 0 to FFormList.Count - 1 do
|
|
TForm(FFormList[i]).Perform(CM_ICONCHANGED, 0, 0);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.SmallIconHandle
|
|
Returns: handle of application icon
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.SmallIconHandle: HIcon;
|
|
begin
|
|
if not Icon.Empty then
|
|
begin
|
|
if FSmallIconHandle = 0 then
|
|
begin
|
|
Icon.OnChange := nil;
|
|
Icon.Current := Icon.GetBestIndexForSize(Size(GetSystemMetrics(SM_CXSMICON), GetSystemMetrics(SM_CYSMICON)));
|
|
FSmallIconHandle := Icon.ReleaseHandle;
|
|
Icon.OnChange := @IconChanged;
|
|
end;
|
|
Result := FSmallIconHandle;
|
|
end
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.BigIconHandle
|
|
Returns: handle of application icon
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.BigIconHandle: HIcon;
|
|
begin
|
|
if not Icon.Empty then
|
|
begin
|
|
if FBigIconHandle = 0 then
|
|
begin
|
|
Icon.OnChange := nil;
|
|
Icon.Current := Icon.GetBestIndexForSize(Size(GetSystemMetrics(SM_CXICON), GetSystemMetrics(SM_CYICON)));
|
|
FBigIconHandle := Icon.ReleaseHandle;
|
|
Icon.OnChange := @IconChanged;
|
|
end;
|
|
Result := FBigIconHandle;
|
|
end
|
|
else
|
|
Result := 0;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.GetTitle
|
|
Returns: title of application
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.GetTitle: string;
|
|
begin
|
|
Result := inherited Title;
|
|
if Result = '' then
|
|
Result := ExtractFileNameOnly(GetExeName);
|
|
end;
|
|
|
|
procedure TApplication.FreeIconHandles;
|
|
begin
|
|
if FSmallIconHandle <> 0 then
|
|
begin
|
|
DestroyIcon(FSmallIconHandle);
|
|
FSmallIconHandle := 0;
|
|
end;
|
|
|
|
if FBigIconHandle <> 0 then
|
|
begin
|
|
DestroyIcon(FBigIconHandle);
|
|
FBigIconHandle := 0;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.HandleException
|
|
Params: Sender
|
|
Returns: Nothing
|
|
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.HandleException(Sender: TObject);
|
|
var
|
|
i: LongInt;
|
|
Skip: Boolean;
|
|
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;
|
|
|
|
Skip := ExceptObject is EAbort;
|
|
|
|
if not (AppNoExceptionMessages in FFlags) then
|
|
begin
|
|
// before we do anything, write it down
|
|
if ExceptObject is Exception then
|
|
begin
|
|
if not Skip then
|
|
begin
|
|
DebugLn('TApplication.HandleException ',Exception(ExceptObject).Message);
|
|
DumpExceptionBackTrace;
|
|
end;
|
|
end else
|
|
begin
|
|
DebugLn('TApplication.HandleException Strange Exception ');
|
|
DumpExceptionBackTrace;
|
|
end;
|
|
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);
|
|
if not Skip then
|
|
RemoveStayOnTop;
|
|
// handle the exception
|
|
if ExceptObject is Exception then
|
|
begin
|
|
if not Skip then
|
|
begin
|
|
i := FApplicationHandlers[ahtException].Count;
|
|
if Assigned(OnException) or (i > 0) then
|
|
begin
|
|
if Assigned(OnException) then
|
|
OnException(Sender, Exception(ExceptObject));
|
|
while FApplicationHandlers[ahtException].NextDownIndex(i) do
|
|
TExceptionEvent(FApplicationHandlers[ahtException][i])(Sender, Exception(ExceptObject));
|
|
end
|
|
else
|
|
ShowException(Exception(ExceptObject));
|
|
end;
|
|
end
|
|
else
|
|
SysUtils.ShowException(ExceptObject, ExceptAddr);
|
|
if not Skip then
|
|
RestoreStayOnTop;
|
|
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.ShowHelpForObject(Sender: TObject);
|
|
begin
|
|
if Sender is TControl then begin
|
|
TControl(Sender).ShowHelp;
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.RemoveStayOnTop;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.RemoveStayOnTop;
|
|
var
|
|
i: Integer;
|
|
AForm: TCustomForm;
|
|
begin
|
|
if WidgetSet.AppRemoveStayOnTopFlags then
|
|
Exit;
|
|
if Screen = nil then
|
|
Exit;
|
|
for i := 0 to Screen.CustomFormCount - 1 do
|
|
begin
|
|
AForm := Screen.CustomForms[i];
|
|
if (AForm.Parent <> nil) or not AForm.Visible then
|
|
Continue;
|
|
if (AForm.FormStyle in fsAllStayOnTop) then
|
|
begin
|
|
AForm.FormStyle := fsNormal;
|
|
if FRestoreStayOnTop = nil then
|
|
FRestoreStayOnTop := TList.Create;
|
|
if FRestoreStayOnTop.IndexOf(AForm) = -1 then
|
|
FRestoreStayOnTop.Add(AForm);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.RestoreStayOnTop;
|
|
var
|
|
i: integer;
|
|
begin
|
|
if WidgetSet.AppRestoreStayOnTopFlags then
|
|
Exit;
|
|
if FRestoreStayOnTop <> nil then
|
|
for i := FRestoreStayOnTop.Count - 1 downto 0 do
|
|
begin
|
|
TCustomForm(FRestoreStayOnTop[i]).FormStyle := fsStayOnTop;
|
|
FRestoreStayOnTop.Delete(i);
|
|
end;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
function TApplication.IsWaiting: boolean;
|
|
------------------------------------------------------------------------------}
|
|
function TApplication.IsWaiting: boolean;
|
|
begin
|
|
Result:=AppWaiting in FFlags;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.CancelHint;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.CancelHint;
|
|
begin
|
|
StopHintTimer;
|
|
HideHint;
|
|
FHintControl := nil;
|
|
FHintTimerType := ahttNone;
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.HideHint;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.HideHint;
|
|
begin
|
|
if FHintWindow <> nil then
|
|
FHintWindow.Visible := False;
|
|
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;
|
|
begin
|
|
repeat
|
|
if CaptureExceptions then
|
|
try // run with try..except
|
|
HandleMessage;
|
|
except
|
|
HandleException(Self);
|
|
end
|
|
else
|
|
HandleMessage; // run without try..except
|
|
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) or (FApplicationHandlers[ahtHint].Count > 0) then
|
|
begin
|
|
if Assigned(FOnHint) then
|
|
FOnHint(Self);
|
|
FApplicationHandlers[ahtHint].CallNotifyEvents(Self);
|
|
end 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 FindInvalidUTF8Character(PChar(Msg), Length(Msg), False) > 0 then
|
|
Msg := AnsiToUtf8(Msg);
|
|
if (Msg <> '') and (Msg[length(Msg)] <> '.') then Msg := Msg + '.';
|
|
if (not Terminated) and (Self <> nil) and (AppInitialized in FFlags) 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 WidgetSet.IsHelpKey(Key, Shift) then
|
|
ShowHelpForObject(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);
|
|
//debugln('TApplication.ControlKeyDown A ',DbgSName(AControl));
|
|
FLastKeyDownSender := AControl;
|
|
|
|
// handle navigation key
|
|
DoTabKey(AControl, Key, Shift);
|
|
DoArrowKey(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.AddOnExceptionHandler(Handler: TExceptionEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtException,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnExceptionHandler(Handler: TExceptionEvent);
|
|
begin
|
|
RemoveHandler(ahtException,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnEndSessionHandler(Handler: TNotifyEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtEndSession,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnEndSessionHandler(Handler: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(ahtEndSession,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnQueryEndSessionHandler(
|
|
Handler: TQueryEndSessionEvent; AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtQueryEndSession,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnQueryEndSessionHandler(
|
|
Handler: TQueryEndSessionEvent);
|
|
begin
|
|
RemoveHandler(ahtQueryEndSession,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnMinimizeHandler(Handler: TNotifyEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtMinimize,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnMinimizeHandler(Handler: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(ahtMinimize,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnRestoreHandler(Handler: TNotifyEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtRestore,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnRestoreHandler(Handler: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(ahtRestore,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnDropFilesHandler(Handler: TDropFilesEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtDropFiles,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnDropFilesHandler(Handler: TDropFilesEvent);
|
|
begin
|
|
RemoveHandler(ahtDropFiles,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnHelpHandler(Handler: THelpEvent; AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtHelp,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnHelpHandler(Handler: THelpEvent);
|
|
begin
|
|
RemoveHandler(ahtHelp,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnHintHandler(Handler: TNotifyEvent; AsLast: Boolean
|
|
);
|
|
begin
|
|
AddHandler(ahtHint,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnHintHandler(Handler: TNotifyEvent);
|
|
begin
|
|
RemoveHandler(ahtHint,TMethod(Handler));
|
|
end;
|
|
|
|
procedure TApplication.AddOnShowHintHandler(Handler: TShowHintEvent;
|
|
AsLast: Boolean);
|
|
begin
|
|
AddHandler(ahtShowHint,TMethod(Handler),AsLast);
|
|
end;
|
|
|
|
procedure TApplication.RemoveOnShowHintHandler(Handler: TShowHintEvent);
|
|
begin
|
|
RemoveHandler(ahtShowHint,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);
|
|
FApplicationHandlers[ahtEndSession].CallNotifyEvents(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.IntfQueryEndSession(var Cancel : Boolean);
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfQueryEndSession(var Cancel : Boolean);
|
|
var
|
|
i: LongInt;
|
|
begin
|
|
if Assigned(FOnQueryEndSession) then FOnQueryEndSession(Cancel);
|
|
i:=FApplicationHandlers[ahtQueryEndSession].Count;
|
|
while FApplicationHandlers[ahtQueryEndSession].NextDownIndex(i) do
|
|
TQueryEndSessionEvent(FApplicationHandlers[ahtQueryEndSession][i])(Cancel);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.IntfAppMinimize;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfAppMinimize;
|
|
begin
|
|
if Assigned(FOnMinimize) then FOnMinimize(Self);
|
|
FApplicationHandlers[ahtMinimize].CallNotifyEvents(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
procedure TApplication.IntfAppRestore;
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfAppRestore;
|
|
begin
|
|
Screen.RestoreLastActive;
|
|
if Assigned(FOnRestore) then FOnRestore(Self);
|
|
FApplicationHandlers[ahtRestore].CallNotifyEvents(Self);
|
|
end;
|
|
|
|
{------------------------------------------------------------------------------
|
|
Method: TApplication.IntfDropFiles
|
|
Params: FileNames - Dropped files
|
|
|
|
Invokes OnDropFilesEvent of the application.
|
|
This function is called by the interface.
|
|
------------------------------------------------------------------------------}
|
|
procedure TApplication.IntfDropFiles(const FileNames: array of String);
|
|
var
|
|
i: LongInt;
|
|
begin
|
|
if Assigned(FOnDropFiles) then FOnDropFiles(Self, FileNames);
|
|
i:=FApplicationHandlers[ahtDropFiles].Count;
|
|
while FApplicationHandlers[ahtDropFiles].NextDownIndex(i) do
|
|
TDropFilesEvent(FApplicationHandlers[ahtDropFiles][i])(Self,Filenames);
|
|
end;
|
|
|
|
procedure TApplication.IntfThemeOptionChange(AThemeServices: TThemeServices;
|
|
AOption: TThemeOption);
|
|
begin
|
|
case AOption of
|
|
toShowButtonImages:
|
|
if ShowButtonGlyphs = sbgSystem then
|
|
NotifyCustomForms(CM_APPSHOWBTNGLYPHCHANGED);
|
|
toShowMenuImages:
|
|
if ShowMenuGlyphs = sbgSystem then
|
|
NotifyCustomForms(CM_APPSHOWMENUGLYPHCHANGED);
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.DoArrowKey(AControl: TWinControl; var Key: Word;
|
|
Shift: TShiftState);
|
|
begin
|
|
if (Key in [VK_LEFT, VK_RIGHT, VK_UP, VK_DOWN]) and (Shift = []) and
|
|
(anoArrowToSelectNextInParent in Navigation) and AControl.Focused and
|
|
(AControl.Parent <> nil) and
|
|
(AControl.Perform(CM_WANTSPECIALKEY, Key, 0) = 0) then
|
|
begin
|
|
// traverse controls inside parent
|
|
AControl.Parent.SelectNext(AControl, Key in [VK_RIGHT, VK_DOWN], False);
|
|
Key := VK_UNKNOWN;
|
|
end;
|
|
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 and
|
|
(AControl.Perform(CM_WANTSPECIALKEY, Key, 0) = 0) then
|
|
begin
|
|
// traverse tabstop controls inside form
|
|
AControl.PerformTab(not (ssShift in Shift));
|
|
Key := VK_UNKNOWN;
|
|
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);
|
|
begin
|
|
if Data<>0 then
|
|
DebugLn(['HINT: TApplication.FreeComponent Data<>0 ignored']);
|
|
ReleaseComponents;
|
|
end;
|
|
|
|
procedure TApplication.ReleaseComponents;
|
|
var
|
|
List: TFPList;
|
|
Node: TAvgLvlTreeNode;
|
|
Component: TComponent;
|
|
i: Integer;
|
|
begin
|
|
if FComponentsToRelease<>nil then begin
|
|
// free components
|
|
// Notes:
|
|
// - check TLCLComponent.LCLRefCount=0
|
|
// - during freeing new components can be added to the FComponentsToRelease
|
|
List:=nil;
|
|
try
|
|
// collect all components that can be freed
|
|
Node:=FComponentsToRelease.FindLowest;
|
|
while Node<>nil do begin
|
|
Component:=TComponent(Node.Data);
|
|
if (not (Component is TLCLComponent))
|
|
or (TLCLComponent(Component).LCLRefCount=0) then begin
|
|
if List=nil then
|
|
List:=TFPList.Create;
|
|
List.Add(Component);
|
|
end;
|
|
Node:=FComponentsToRelease.FindSuccessor(Node);
|
|
end;
|
|
// free components
|
|
if List<>nil then
|
|
for i:=0 to List.Count-1 do begin
|
|
Component:=TComponent(List[i]);
|
|
FComponentsToRelease.Remove(Component);
|
|
//DebugLn(['TApplication.ReleaseComponents ',DbgSName(Component)]);
|
|
Component.Free;
|
|
end;
|
|
finally
|
|
List.Free;
|
|
end;
|
|
if FComponentsToRelease.Count=0 then
|
|
FreeAndNil(FComponentsToRelease);
|
|
end;
|
|
end;
|
|
|
|
procedure TApplication.ReleaseComponent(AComponent: TComponent);
|
|
var
|
|
IsFirstItem: Boolean;
|
|
begin
|
|
if csDestroying in AComponent.ComponentState then exit;
|
|
//DebugLn(['TApplication.ReleaseComponent ',DbgSName(AComponent)]);
|
|
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;
|