source: trunk/Packages/DpiControls/Dpi.Forms.pas

unit Dpi.Forms;

interface

uses
  Classes, SysUtils, Forms, LMessages, Controls, LCLType,
  Generics.Collections, LCLProc, LResources, Graphics, Dpi.Controls,
  Dpi.Graphics;

const
  crDefault = TCursor(0);

type
  TMessageEvent = procedure (var TheMessage : TLMessage) of object;
  TCloseAction = Forms.TCloseAction;
  TFormState = Forms.TFormState;
  TFormStateType = Forms.TFormStateType;
  TWindowState = Forms.TWindowState;
  TScrollBarKind = Forms.TScrollBarKind;
  TBorderIcon = Forms.TBorderIcon;
  TShowInTaskbar = Forms.TShowInTaskbar;
  TTaskBarBehavior = Forms.TTaskBarBehavior;

  { TFormEx }

  TFormEx = class(Forms.TForm)
  private
    FOnMessage: TMessageEvent;
  protected
    procedure WndProc(var TheMessage : TLMessage); override;
    property OnMessage: TMessageEvent read FOnMessage write FOnMessage;
  end;

  { TControlScrollBar }

  TControlScrollBar = class(TPersistent)
  private
    function GetVisible: Boolean;
    procedure SetVisible(AValue: Boolean);
  published
    property Visible: Boolean read GetVisible write SetVisible;
  end;

  { TScrollingWinControl }

  TScrollingWinControl = class(TCustomControl)
  private
    FHorzScrollBar: TControlScrollBar;
    FVertScrollBar: TControlScrollBar;
  protected
    function GetNativeCustomControl: Controls.TCustomControl; override;
    function GetNativeScrollingWinControl: Forms.TScrollingWinControl; virtual;
  public
    constructor Create(TheOwner: TComponent); override;
    destructor Destroy; override;
  published
    property HorzScrollBar: TControlScrollBar read FHorzScrollBar write FHorzScrollBar;
    property VertScrollBar: TControlScrollBar read FVertScrollBar write FVertScrollBar;
  end;

  { TForm }

  TForm = class(TScrollingWinControl)
  private
    FOnActivate: TNotifyEvent;
    FOnClose: TCloseEvent;
    FOnCloseQuery: TCloseQueryEvent;
    FOnDeactivate: TNotifyEvent;
    function GetBorderIcons: TBorderIcons;
    function GetBorderStyle: TFormBorderStyle;
    function GetDesignTimePPI: Integer;
    function GetFormState: TFormState;
    function GetFormStyle: TFormStyle;
    function GetKeyPreview: Boolean;
    function GetLCLVersion: string;
    function GetModalResult: TModalResult;
    function GetOnCloseQuery: TCloseQueryEvent;
    function GetOnCreate: TNotifyEvent;
    function GetOnDeactivate: TNotifyEvent;
    function GetOnDestroy: TNotifyEvent;
    function GetOnHide: TNotifyEvent;
    function GetOnShow: TNotifyEvent;
    function GetPosition: TPosition;
    function GetRestoredHeight: Integer;
    function GetRestoredLeft: Integer;
    function GetRestoredTop: Integer;
    function GetRestoredWidth: Integer;
    function GetShowInTaskbar: TShowInTaskbar;
    function GetWindowState: TWindowState;
    procedure SetBorderIcons(AValue: TBorderIcons);
    procedure SetBorderStyle(AValue: TFormBorderStyle);
    procedure SetDesignTimePPI(AValue: Integer);
    procedure SetFormStyle(AValue: TFormStyle);
    procedure SetKeyPreview(AValue: Boolean);
    procedure SetLCLVersion(AValue: string);
    procedure SetModalResult(AValue: TModalResult);
    procedure SetOnCloseQuery(AValue: TCloseQueryEvent);
    procedure SetOnCreate(AValue: TNotifyEvent);
    procedure SetOnDeactivate(AValue: TNotifyEvent);
    procedure SetOnDestroy(AValue: TNotifyEvent);
    procedure SetOnHide(AValue: TNotifyEvent);
    procedure SetOnShow(AValue: TNotifyEvent);
    procedure DoOnCreate;
    procedure FormMessageHandler(var TheMessage: TLMessage);
    procedure SetPosition(AValue: TPosition);
    procedure SetShowInTaskBar(AValue: TShowInTaskbar);
    procedure SetWindowState(AValue: TWindowState);
    procedure ActivateHandler(Sender: TObject);
    procedure DeactivateHandler(Sender: TObject);
    procedure DoClose(var CloseAction: TCloseAction); virtual;
    procedure CloseHandler(Sender: TObject; var CloseAction: TCloseAction);
    procedure CloseQueryHandler(Sender : TObject; var CanClose : boolean);
  protected
    procedure CreateParams(var p: TCreateParams); virtual;
    procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
    function GetNativeScrollingWinControl: Forms.TScrollingWinControl; override;
    function GetNativeForm: Forms.TForm; virtual;
    procedure UpdateNativeControl; override;
  public
    NativeForm: Forms.TForm;
    procedure AfterConstruction; override;
    property ModalResult: TModalResult read GetModalResult write SetModalResult;
    function ShowModal: Integer; virtual;
    procedure SetFocus; override;
    procedure Close;
    function CloseQuery: boolean; virtual;
    procedure BringToFront;
    procedure Release;
    constructor Create(TheOwner: TComponent); override;
    constructor CreateNew(AOwner: TComponent; Num: Integer = 0); virtual;
    destructor Destroy; override;
  published
    property RestoredLeft: integer read GetRestoredLeft;
    property RestoredTop: integer read GetRestoredTop;
    property RestoredWidth: integer read GetRestoredWidth;
    property RestoredHeight: integer read GetRestoredHeight;
    property DesignTimePPI: Integer read GetDesignTimePPI write SetDesignTimePPI; // Not used
    property FormState: TFormState read GetFormState;
    property FormStyle: TFormStyle read GetFormStyle write SetFormStyle;
    property BorderStyle: TFormBorderStyle read GetBorderStyle write SetBorderStyle default bsSizeable;
    property BorderIcons: TBorderIcons read GetBorderIcons write SetBorderIcons;
    property LCLVersion: string read GetLCLVersion write SetLCLVersion;
    property KeyPreview: Boolean read GetKeyPreview write SetKeyPreview default False;
    property Position: TPosition read GetPosition write SetPosition default poDesigned;
    property WindowState: TWindowState read GetWindowState write SetWindowState default wsNormal;
    property OnShow: TNotifyEvent read GetOnShow write SetOnShow;
    property OnHide: TNotifyEvent read GetOnHide write SetOnHide;
    property OnCreate: TNotifyEvent read GetOnCreate write SetOnCreate;
    property OnDestroy: TNotifyEvent read GetOnDestroy write SetOnDestroy;
    property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
    property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
    property OnClose: TCloseEvent read FOnClose write FOnClose;
    property OnCloseQuery: TCloseQueryEvent read FOnCloseQuery write FOnCloseQuery;
    property ClientHeight;
    property ClientWidth;
    property OnMouseUp;
    property OnMouseDown;
    property OnMouseMove;
    property ShowInTaskBar: TShowInTaskbar read GetShowInTaskbar write SetShowInTaskBar
                                        default stDefault;
  end;

  TForms = TObjectList<TForm>;

  { TApplication }

  TApplication = class(TComponent)
  private
    FMainForm: TForm;
    FCreatingForm: TForm;
    function GetActive: Boolean;
    function GetExeName: string;
    function GetShowMainForm: Boolean;
    function GetTaskBarBehavior: TTaskBarBehavior;
    function GetTitle: string;
    procedure SetMainForm(AValue: TForm);
    function GetMainForm: TForm;
    procedure SetShowMainForm(AValue: Boolean);
    procedure SetTaskBarBehavior(AValue: TTaskBarBehavior);
    procedure SetTitle(AValue: string);
  protected
    function GetNativeApplication: Forms.TApplication; virtual;
    procedure DoBeforeFinalization;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run;
    procedure Initialize;
    procedure Terminate;
    procedure ProcessMessages;
    procedure UpdateMainForm(AForm: TForm);
    procedure CreateForm(InstanceClass: TComponentClass; out Reference);
    procedure RemoveStayOnTop(const ASystemTopAlso: Boolean = False);
    procedure RestoreStayOnTop(const ASystemTopAlso: Boolean = False);
    function MessageBox(Text, Caption: PChar; Flags: Longint = MB_OK): Integer;
    property MainForm: TForm read GetMainForm write SetMainForm;
    property ShowMainForm: Boolean read GetShowMainForm write SetShowMainForm default True;
    property Title: string read GetTitle write SetTitle;
    property Active: Boolean read GetActive;
    property ExeName: string read GetExeName;
    property TaskBarBehavior: TTaskBarBehavior read GetTaskBarBehavior write SetTaskBarBehavior;
  end;

  { TScreen }

  TScreen = class
  private
    FDpi: Integer;
    FActiveForm: TForm;
    FPrevActiveForms: TForms;
    FForms: TForms;
    procedure AddForm(AForm: TForm);
    function GetDesktopHeight: Integer;
    function GetDesktopLeft: Integer;
    function GetDesktopTop: Integer;
    function GetDesktopWidth: Integer;
    procedure RemoveForm(AForm: TForm);
    function GetActiveForm: TForm;
    function GetCursor: TCursor;
    function GetCursors(Index: Integer): HCURSOR;
    function GetFormCount: Integer;
    function GetForms(Index: Integer): TForm;
    function GetHeight: Integer;
    function GetWidth: Integer;
    procedure SetCursor(AValue: TCursor);
    procedure SetCursors(Index: Integer; AValue: HCURSOR);
    procedure SetDpi(AValue: Integer);
    procedure UpdateForms;
  public
    constructor Create;
    destructor Destroy; override;
    procedure UpdateActiveFormFromNativeScreen;
    function DisableForms(SkipForm: TForm; DisabledList: Classes.TList = nil): Classes.TList;
    procedure EnableForms(var AFormList: Classes.TList);
    function GetSystemDpi: Integer;
    property FormCount: Integer read GetFormCount;
    property Forms[Index: Integer]: TForm read GetForms;
    property ActiveForm: TForm read GetActiveForm;
    property Cursor: TCursor read GetCursor write SetCursor;
    property Cursors[Index: Integer]: HCURSOR read GetCursors write SetCursors;
  published
    property Dpi: Integer read FDpi write SetDpi;
    property PixelsPerInch: Integer read FDpi;
    property Width: Integer read GetWidth;
    property Height: Integer read GetHeight;
    property DesktopLeft: Integer read GetDesktopLeft;
    property DesktopTop: Integer read GetDesktopTop;
    property DesktopWidth: Integer read GetDesktopWidth;
    property DesktopHeight: Integer read GetDesktopHeight;
  end;

var
  Application: TApplication;
  Screen: TScreen;


implementation

uses
  Dpi.Common;

var
  LCLScreen: Forms.TScreen absolute Forms.Screen;

{ TFormEx }

procedure TFormEx.WndProc(var TheMessage: TLMessage);
begin
  inherited WndProc(TheMessage);
  if Assigned(FOnMessage) then
    FOnMessage(TheMessage);
end;

{ TScrollingWinControl }

function TScrollingWinControl.GetNativeCustomControl: Controls.TCustomControl;
begin
  Result := GetNativeScrollingWinControl;
end;

function TScrollingWinControl.GetNativeScrollingWinControl: Forms.TScrollingWinControl;
begin
  Result := nil;
end;

constructor TScrollingWinControl.Create(TheOwner: TComponent);
begin
  inherited;
  FHorzScrollBar := TControlScrollBar.Create;
  FVertScrollBar := TControlScrollBar.Create;
end;

destructor TScrollingWinControl.Destroy;
begin
  FreeAndNil(FHorzScrollBar);
  FreeAndNil(FVertScrollBar);
  inherited;
end;

{ TApplication }

procedure TApplication.SetMainForm(AValue: TForm);
begin
  FMainForm := AValue;
end;

function TApplication.GetTitle: string;
begin
  Result := GetNativeApplication.Title;
end;

function TApplication.GetShowMainForm: Boolean;
begin
  Result := GetNativeApplication.ShowMainForm;
end;

function TApplication.GetTaskBarBehavior: TTaskBarBehavior;
begin
  Result := GetNativeApplication.TaskBarBehavior;
end;

function TApplication.GetActive: Boolean;
begin
  Result := GetNativeApplication.Active;
end;

function TApplication.GetExeName: string;
begin
  Result := GetNativeApplication.ExeName;
end;

function TApplication.GetMainForm: TForm;
begin
  Result := FMainForm;
end;

procedure TApplication.SetShowMainForm(AValue: Boolean);
begin
  GetNativeApplication.ShowMainForm := AValue;
end;

procedure TApplication.SetTaskBarBehavior(AValue: TTaskBarBehavior);
begin
  GetNativeApplication.TaskBarBehavior := AValue;
end;

procedure TApplication.SetTitle(AValue: string);
begin
  GetNativeApplication.Title := AValue;
end;

function TApplication.GetNativeApplication: Forms.TApplication;
begin
  Result := Forms.Application;
end;

procedure DpiBeforeFinalization;
// This is our ExitProc handler.
begin
  Application.DoBeforeFinalization;
end;

procedure TApplication.DoBeforeFinalization;
var
  I: Integer;
begin
  if Self = nil then Exit;
  for I := ComponentCount - 1 downto 0 do begin
    if I < ComponentCount then
      Components[I].Free;
  end;
end;

function DpiFindApplicationComponent(const ComponentName: string): TComponent;
// Note: this function is used by TReader to auto rename forms to unique names.
begin
  Result := Application.FindComponent(ComponentName);
end;

constructor TApplication.Create(AOwner: TComponent);
begin
  RegisterFindGlobalComponentProc(@DpiFindApplicationComponent);
  AddExitProc(@DpiBeforeFinalization);
  inherited;
end;

destructor TApplication.Destroy;
begin
  UnregisterFindGlobalComponentProc(@DpiFindApplicationComponent);
  inherited;
end;

procedure TApplication.Run;
begin
  if (FMainForm <> nil) and GetShowMainForm then FMainForm.Show;
  GetNativeApplication.Run;
end;

procedure TApplication.Initialize;
begin
  GetNativeApplication.Initialize;
end;

procedure TApplication.Terminate;
begin
  GetNativeApplication.Terminate;
end;

procedure TApplication.ProcessMessages;
begin
  GetNativeApplication.ProcessMessages;
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;
  GetNativeApplication.UpdateMainForm(AForm.GetNativeForm);
end;

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.GetNativeForm.HandleNeeded;
    if AForm.FormStyle = fsSplash then begin
      // show the splash form and handle the paint message
      AForm.Show;
      AForm.Invalidate;
      ProcessMessages;
    end;
  end;
end;

procedure TApplication.RemoveStayOnTop(const ASystemTopAlso: Boolean);
begin
  GetNativeApplication.RemoveStayOnTop(ASystemTopAlso);
end;

procedure TApplication.RestoreStayOnTop(const ASystemTopAlso: Boolean);
begin
  GetNativeApplication.RestoreStayOnTop(ASystemTopAlso);
end;

function TApplication.MessageBox(Text, Caption: PChar; Flags: Longint
  ): Integer;
begin
  Result := Application.MessageBox(Text, Caption, Flags);
end;

{ TForm }

function TForm.GetBorderIcons: TBorderIcons;
begin
  Result := GetNativeForm.BorderIcons;
end;

function TForm.GetBorderStyle: TFormBorderStyle;
begin
  Result := GetNativeForm.BorderStyle;
end;

function TForm.GetDesignTimePPI: Integer;
begin
  Result := GetNativeForm.DesignTimePPI;
end;

function TForm.GetFormState: TFormState;
begin
  Result := GetNativeForm.FormState;
end;

function TForm.GetFormStyle: TFormStyle;
begin
  Result := GetNativeForm.FormStyle;
end;

function TForm.GetKeyPreview: Boolean;
begin
  Result := GetNativeForm.KeyPreview;
end;

function TForm.GetLCLVersion: string;
begin
  Result := GetNativeForm.LCLVersion;
end;

function TForm.GetModalResult: TModalResult;
begin
  Result := GetNativeForm.ModalResult;
end;

function TForm.GetOnCloseQuery: TCloseQueryEvent;
begin
  Result := GetNativeForm.OnCloseQuery;
end;

function TForm.GetOnCreate: TNotifyEvent;
begin
  Result := GetNativeForm.OnCreate;
end;

function TForm.GetOnDeactivate: TNotifyEvent;
begin
  Result := GetNativeForm.OnDeactivate;
end;

function TForm.GetOnDestroy: TNotifyEvent;
begin
  Result := GetNativeForm.OnDestroy;
end;

function TForm.GetOnHide: TNotifyEvent;
begin
  Result := GetNativeForm.OnHide;
end;

function TForm.GetOnShow: TNotifyEvent;
begin
  Result := GetNativeForm.OnShow;
end;

function TForm.GetPosition: TPosition;
begin
  Result := GetNativeForm.Position;
end;

function TForm.GetRestoredHeight: Integer;
begin
  Result := ScaleFromNative(GetNativeForm.RestoredHeight);
end;

function TForm.GetRestoredLeft: Integer;
begin
  Result := ScaleFromNative(GetNativeForm.RestoredLeft);
end;

function TForm.GetRestoredTop: Integer;
begin
  Result := ScaleFromNative(GetNativeForm.RestoredTop);
end;

function TForm.GetRestoredWidth: Integer;
begin
  Result := ScaleFromNative(GetNativeForm.RestoredWidth);
end;

function TForm.GetShowInTaskbar: TShowInTaskbar;
begin
  Result := GetNativeForm.ShowInTaskBar;
end;

function TForm.GetWindowState: TWindowState;
begin
  Result := GetNativeForm.WindowState;
end;

procedure TForm.SetBorderIcons(AValue: TBorderIcons);
begin
  GetNativeForm.BorderIcons := AValue;
end;

procedure TForm.SetBorderStyle(AValue: TFormBorderStyle);
begin
  GetNativeForm.BorderStyle := AValue;
end;

procedure TForm.SetDesignTimePPI(AValue: Integer);
begin
  GetNativeForm.DesignTimePPI := AValue;
end;

procedure TForm.SetFormStyle(AValue: TFormStyle);
begin
  GetNativeForm.FormStyle := AValue;
end;

procedure TForm.SetKeyPreview(AValue: Boolean);
begin
  GetNativeForm.KeyPreview := AValue;
end;

procedure TForm.SetLCLVersion(AValue: string);
begin
  GetNativeForm.LCLVersion := AValue;
end;

procedure TForm.SetModalResult(AValue: TModalResult);
begin
  GetNativeForm.ModalResult := AValue;
end;

procedure TForm.SetOnCloseQuery(AValue: TCloseQueryEvent);
begin
  GetNativeForm.OnCloseQuery := AValue;
end;

procedure TForm.SetOnCreate(AValue: TNotifyEvent);
begin
  GetNativeForm.OnCreate := AValue;
end;

procedure TForm.SetOnDeactivate(AValue: TNotifyEvent);
begin
  GetNativeForm.OnDeactivate := AValue;
end;

procedure TForm.SetOnDestroy(AValue: TNotifyEvent);
begin
  GetNativeForm.OnDestroy := AValue;
end;

procedure TForm.SetOnHide(AValue: TNotifyEvent);
begin
  GetNativeForm.OnHide := AValue;
end;

procedure TForm.SetOnShow(AValue: TNotifyEvent);
begin
  GetNativeForm.OnShow := AValue;
end;

procedure TForm.DoOnCreate;
begin
  if Assigned(GetNativeForm.OnCreate) then
    GetNativeForm.OnCreate(Self);
end;

procedure TForm.FormMessageHandler(var TheMessage: TLMessage);
begin
  Dispatch(TheMessage);
end;

procedure TForm.SetPosition(AValue: TPosition);
begin
  GetNativeForm.Position := AValue;
end;

procedure TForm.SetShowInTaskBar(AValue: TShowInTaskbar);
begin
  GetNativeForm.ShowInTaskBar := AValue;
end;

procedure TForm.SetWindowState(AValue: TWindowState);
begin
  GetNativeForm.WindowState := AValue;
end;

procedure TForm.ActivateHandler(Sender: TObject);
begin
  if Assigned(Screen.FActiveForm) then begin
    if Screen.FPrevActiveForms.IndexOf(Screen.FActiveForm) <> - 1 then
      Screen.FPrevActiveForms.Remove(Screen.FActiveForm);
    Screen.FPrevActiveForms.Add(Screen.FActiveForm);
  end;
  Screen.FActiveForm := Self;
  if Assigned(FOnActivate) then FOnActivate(Sender);
end;

procedure TForm.DeactivateHandler(Sender: TObject);
begin
  if Screen.FPrevActiveForms.Count > 0 then begin
    Screen.FActiveForm := Screen.FPrevActiveForms.Last;
    Screen.FPrevActiveForms.Delete(Screen.FPrevActiveForms.Count - 1);
  end else Screen.FActiveForm := nil;
  //Screen.UpdateActiveFormFromNativeScreen;
  if Assigned(FOnDeactivate) then FOnDeactivate(Sender);
end;

procedure TForm.DoClose(var CloseAction: TCloseAction);
begin
  if Assigned(FOnClose) then FOnClose(Self, CloseAction);
end;

procedure TForm.CloseHandler(Sender: TObject; var CloseAction: TCloseAction);
begin
  Close;
end;

procedure TForm.CloseQueryHandler(Sender : TObject; var CanClose : boolean);
begin
  if Assigned(FOnCloseQuery) then FOnCloseQuery(Self, CanClose);
end;

procedure TForm.CreateParams(var p: TCreateParams);
begin
  // TODO: NativeForm.CreateParams(P);
end;

// This method is called by TWriter to retrieve the child components to write
procedure TForm.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
  I: Integer;
  OwnedComponent: TComponent;
begin
  DebugLn(['TDpiForm.GetChildren ComponentCount=', ComponentCount]);
  inherited GetChildren(Proc, Root);
  if Root = Self then begin
    for I := 0 to ComponentCount - 1 do begin
      OwnedComponent := Components[I];
      if not OwnedComponent.HasParent then Proc(OwnedComponent);
    end;
  end;
end;

function TForm.GetNativeScrollingWinControl: Forms.TScrollingWinControl;
begin
  Result := GetNativeForm;
end;

function TForm.GetNativeForm: Forms.TForm;
begin
  if not Assigned(NativeForm) then begin
    NativeForm := TFormEx.CreateNew(nil);
    (NativeForm as TFormEx).OnMessage := FormMessageHandler;
    //NativeForm := Forms.TForm.Create(nil);
  end;
  Result := NativeForm;
end;

procedure TForm.UpdateNativeControl;
begin
  inherited;
  GetNativeForm.OnActivate := ActivateHandler;
  GetNativeForm.OnDeactivate := DeactivateHandler;
  GetNativeForm.OnClose := CloseHandler;
  GetNativeForm.OnCloseQuery := CloseQueryHandler;
  GetNativeForm.Name := Name + 'Native';
end;

procedure TForm.AfterConstruction;
begin
  inherited;
  DoOnCreate;
end;

function TForm.ShowModal: Integer;
begin
  Result := GetNativeForm.ShowModal;
end;

procedure TForm.SetFocus;
begin
  GetNativeForm.SetFocus;
end;

procedure TForm.Close;
var
  CloseAction: TCloseAction;
  IsMainForm: Boolean;
begin
  if (fsModal in FormState) and (ModalResult = 0) then
    ModalResult := mrCancel
  else
  begin
    if CloseQuery then
    begin
      // IsMainForm flag set if we are closing MainForm or its parent
      IsMainForm := (Application.MainForm = Self) or (Self.IsParentOf(Application.MainForm));
      // Prepare default close action
      if FormStyle = fsMDIChild then
      begin
        CloseAction := caNone;
        // TODO: mdi logic
      end
      else
      begin
        if IsMainForm then
          CloseAction := caFree
        else
          CloseAction := caHide;
      end;
      // call event handler and let user modify CloseAction
      DoClose(CloseAction);
      // execute action according to close action
      case CloseAction of
        caHide: Hide;
        caMinimize: WindowState := wsMinimized;
        caFree:
          begin
            // if form is MainForm, then terminate the application
            // the owner of the MainForm is the application,
            // so the Application will take care of free-ing the form
            // and Release is not necessary
            if IsMainForm then
              Application.Terminate
            else
              Release;
          end;
      end;
    end;
  end;
end;

function TForm.CloseQuery: boolean;
begin
  Result := True;
  if Assigned(FOnCloseQuery) then
    FOnCloseQuery(Self, Result);
end;

procedure TForm.BringToFront;
begin
  GetNativeForm.BringToFront;
end;

procedure TForm.Release;
begin
  Free;
end;

// Init the component with an IDE resource
constructor TForm.Create(TheOwner: TComponent);
begin
  //inherited;
  //DebugLn(['TDpiForm.Create ', DbgSName(TheOwner)]);
  GlobalNameSpace.BeginWrite;
  try
    CreateNew(TheOwner, 1); // this calls BeginFormUpdate, which is ended in AfterConstruction
    if (ClassType <> TForm) and not (csDesigning in ComponentState) then begin
      if not InitResourceComponent(Self, TDataModule) then begin
        raise EResNotFound.Create('Resource missing for class ' + ClassName);
      end;
    end;
  finally
    GlobalNameSpace.EndWrite;
  end;
  ScreenChanged;
  UpdateNativeControl;
end;

constructor TForm.CreateNew(AOwner: TComponent; Num: Integer);
begin
  inherited Create(AOwner);
  Screen.AddForm(Self);
end;

destructor TForm.Destroy;
begin
  // TODO: Can't destroy directly?
  TFormEx(NativeForm).OnMessage := nil;
  FreeAndNil(NativeForm);

  Screen.RemoveForm(Self);
  inherited;
end;

{ TScreen }

procedure TScreen.SetDpi(AValue: Integer);
begin
  if FDpi = AValue then Exit;
  FDpi := AValue;
  ScreenInfo.Dpi := Dpi;
  UpdateForms;
end;

function TScreen.GetWidth: Integer;
begin
  Result := ScaleFromNative(LCLScreen.Width);
end;

procedure TScreen.SetCursor(AValue: TCursor);
begin
  LCLScreen.Cursor := AValue;
end;

procedure TScreen.SetCursors(Index: Integer; AValue: HCURSOR);
begin
  LCLScreen.Cursors[Index] := AValue;
end;

function TScreen.GetHeight: Integer;
begin
  Result := ScaleFromNative(LCLScreen.Height);
end;

function TScreen.GetFormCount: Integer;
begin
  Result := FForms.Count;
end;

function TScreen.GetForms(Index: Integer): TForm;
begin
  Result := FForms[Index];
end;

procedure TScreen.AddForm(AForm: TForm);
begin
  if AForm is TForm then begin
    FForms.Add(AForm);
    //Application.UpdateVisible;
  end;
end;

function TScreen.GetDesktopHeight: Integer;
begin
  Result := ScaleFromNative(LCLScreen.DesktopHeight);
end;

function TScreen.GetDesktopLeft: Integer;
begin
  Result := ScaleFromNative(LCLScreen.DesktopLeft);
end;

function TScreen.GetDesktopTop: Integer;
begin
  Result := ScaleFromNative(LCLScreen.DesktopTop);
end;

function TScreen.GetDesktopWidth: Integer;
begin
  Result := ScaleFromNative(LCLScreen.DesktopWidth);
end;

procedure TScreen.RemoveForm(AForm: TForm);
begin
  FForms.Remove(AForm);
  FPrevActiveForms.Remove(AForm);
  if AForm = FActiveForm then begin
    FActiveForm := nil;
  end;
end;

function TScreen.GetActiveForm: TForm;
begin
  Result := FActiveForm;
end;

function TScreen.GetCursor: TCursor;
begin
  Result := LCLScreen.Cursor;
end;

function TScreen.GetCursors(Index: Integer): HCURSOR;
begin
  Result := LCLScreen.Cursors[Index];
end;

procedure TScreen.UpdateForms;
var
  I: Integer;
begin
  for I := 0 to FForms.Count - 1 do
    FForms[I].ScreenChanged;
end;

function TScreen.DisableForms(SkipForm: TForm; DisabledList: Classes.TList
  ): Classes.TList;
begin
  Result := LCLScreen.DisableForms(SkipForm.GetNativeForm, DisabledList);
end;

procedure TScreen.EnableForms(var AFormList: Classes.TList);
begin
  LCLScreen.EnableForms(AFormList);
end;

function TScreen.GetSystemDpi: Integer;
begin
  Result := LCLScreen.PixelsPerInch;
end;

constructor TScreen.Create;
begin
  FForms := TForms.Create;
  FForms.OwnsObjects := False;
  FPrevActiveForms := TForms.Create;
  FPrevActiveForms.OwnsObjects := False;
  // Froms.Screen.PixelsPerInch is not initialized at this point
  Dpi := 96;
end;

destructor TScreen.Destroy;
begin
  FreeAndNil(FForms);
  FreeAndNil(FPrevActiveForms);
  inherited;
end;

procedure TScreen.UpdateActiveFormFromNativeScreen;
var
  I: Integer;
  F: TForm;
begin
  if LCLScreen.ActiveForm = nil then FActiveForm := nil
  else begin
    for I := 0 to FormCount - 1 do begin
      F := Forms[I];
      if F.GetNativeForm = LCLScreen.ActiveForm then begin
        FActiveForm := F;
        Break;
      end;
    end;
  end;
end;

{ TControlScrollBar }

function TControlScrollBar.GetVisible: Boolean;
begin

end;

procedure TControlScrollBar.SetVisible(AValue: Boolean);
begin

end;

initialization

RegisterPropertyToSkip(TForm, 'OldCreateOrder', 'Native compatibility property', '');
RegisterPropertyToSkip(TForm, 'TextHeight', 'Native compatibility property', '');
RegisterPropertyToSkip(TForm, 'Scaled', 'Native compatibility property', '');
RegisterPropertyToSkip(TForm, 'TransparentColorValue', 'Native compatibility property', '');
Screen := TScreen.Create;
Application := TApplication.Create(nil);

finalization

FreeAndNil(Application);
FreeAndNil(Screen);

end.