Logo Search packages:      
Sourcecode: lazarus version File versions

application.inc

{%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 = 100;     { 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;

{------------------------------------------------------------------------------
       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;
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;
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 begin
      FCreatingForm:=nil;
    end;
    if AComponent=FHintWindow then begin
      FHintWindow:=nil;
    end;
    if AComponent=FHintTimer then begin
      FHintTimer:=nil;
    end;
    if AComponent = MainForm then begin
      FMainForm:= nil;
      Terminate;
    end;
  end;
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);
    NotifyIdleHandler;
  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;
 ------------------------------------------------------------------------------}
procedure TApplication.NotifyIdleHandler;
begin
  FApplicationHandlers[ahtIdle].CallNotifyEvents(Self);
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;
  {if (FHintWindow <> nil) and FHintWindow.IsHintMsg(Msg) then
    CancelHint;}
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);
    {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;

  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: TNotifyEvent;
  AsLast: Boolean);
begin
  AddHandler(ahtIdle,TMethod(Handler),AsLast);
end;

procedure TApplication.RemoveOnIdleHandler(Handler: TNotifyEvent);
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;



{------------------------------------------------------------------------------
  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(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
  TComponent(Data).Free;
end;

procedure TApplication.ReleaseComponent(AComponent: TComponent);
begin
  QueueAsyncCall(@FreeComponent, PtrInt(AComponent));
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;

Generated by  Doxygen 1.6.0   Back to index