
{******************************************}
{                                          }
{             FastReport v5.0              }
{              Tool controls               }
{                                          }
{         Copyright (c) 1998-2014          }
{         by Alexander Tzyganenko,         }
{            Fast Reports Inc.             }
{                                          }
{******************************************}

unit frxBaseForm;

interface

{$I frx.inc}

uses
{$IFNDEF FPC}Windows, Messages, {$ENDIF}
  SysUtils, Classes, Graphics, Controls, Forms, IniFiles, frxDPIAwareInt
{$IFDEF FPC}
  , LResources, LCLType, LMessages, LCLIntf, LCLProc, LazarusPackageIntf, LazHelper
{$ENDIF}
{$IFDEF Delphi6}
, Variants
{$ENDIF};

type
  TfrxPreferencesAction = (frPaLoad, frPaSave, frPaRestore);
  TfrxPreferencesType = (frPtFormPos, frPtFormSize, frPtFormVisibility, frPtFormDockInfo, frPtFormDockPos, frPtFormDockSize, frPtFormCustom);
  TfrxPreferencesTypes = set of TfrxPreferencesType;
  TfrxPreferencesLoadEvent = (peAtCreate, peAtShowOnce, peAtShow);

  TfrxMessageObject = class(TObject)
  public
    Msg: Cardinal;
    WParam: WPARAM;
    FormRect: TRect;
  end;

  TfrxBaseForm = class(TForm)
  private
    FCurrentFormPPI: Integer;
    FShowed: Boolean;
    FSavedPPI: Integer;
    FNeedUpdatePPI: Boolean;
    FUpdatingPPI: TfrxMessageObject;
    FPreferences: TfrxPreferencesTypes;
    FIsPPIChanging: Boolean;
    FPrefIsLoaded: Boolean;
    FPrefIsSaved: Boolean;
    FPrefIsLocked: Boolean;
    procedure WMDpiChanged(var Message: TMessage); message FRX_WM_DPICHANGED;
    function GetCurrentFormPPI: Integer;
  protected
    FPrefEvent: TfrxPreferencesLoadEvent;
    FHostedControls: array of TControl;
    procedure DoShow; override;
    procedure DoClose(var Action: TCloseAction); override;
    procedure ChangeScale(M, D: Integer); overload; override;
{$IFDEF DELPHI24}
    procedure ChangeScale(M, D: Integer; isDpiChange: Boolean); overload; override;
{$ENDIF}
    procedure BeforePPIChange; virtual;
    procedure AfterPPIChange; virtual;
    procedure AfterPPIMessage; virtual;
    procedure DoUpdateFormPPI(aNewPPI: Integer);
    { FormShowBeforeLoad and FormShowAfterLoad to prevent form flikering on load }
    procedure FormShowBeforeLoad; virtual;
    procedure LoadFormPreferences(PreferencesStorage: TObject; DefPreferencesStorage: TObject); virtual;
    procedure SaveFormPreferences(PreferencesStorage: TObject; DefPreferencesStorage: TObject); virtual;
    procedure ResetFormPreferences(PreferencesStorage: TObject); virtual;
    function GetFormSectionName: String; virtual;
    function GetAvailablePreferences: TfrxPreferencesTypes; virtual;
  public
    procedure AfterConstruction; override;
    procedure BeforeDestruction; override;
    constructor Create(AOwner: TComponent); override;
    function GetPreferencesStorage(aDefault: Boolean): TObject; virtual;
    procedure ProcessPreferences(aPrefArction: TfrxPreferencesAction); overload;
    procedure ProcessPreferences(aPrefArction: TfrxPreferencesAction; PrefTyp: TfrxPreferencesTypes); overload;
    procedure LoadFormPrefType(PreferencesStorage: TObject; DefPreferencesStorage: TObject; PrefTyp: TfrxPreferencesTypes);
    procedure UpdateResouces; virtual;
    procedure HostControls(Host: TWinControl); virtual;
    procedure UnhostControls(AModalResult: TModalResult); virtual;
    procedure UpdateFormPPI(aNewPPI: Integer); virtual;
    property CurrentFormPPI: Integer read GetCurrentFormPPI;
    procedure SendPPIMessage(aWinControl:TWinControl; aNewPPI: Integer);
    procedure SaveFormPrefType(PreferencesStorage: TObject; DefPreferencesStorage: TObject; PrefTyp: TfrxPreferencesTypes);
{$IFDEF DELPHI24}
    procedure ScaleForPPI(NewPPI: Integer); override;
{$ENDIF}
    property IsPPIChanging: Boolean read FIsPPIChanging;
  end;

  TfrxBaseLoadSavePrefForm = class(TfrxBaseForm)
  protected
    function GetAvailablePreferences: TfrxPreferencesTypes; override;
  end;

implementation


uses frxClass, frxUtils, frxRes, frxDock, Types;

const
  rsForm      = 'Form5';
  rsToolBar   = 'ToolBar5';
  rsDock      = 'Dock5';
  rsWidth     = 'Width';
  rsHeight    = 'Height';
  rsTop       = 'Top';
  rsLeft      = 'Left';
  rsFloat     = 'Float';
  rsVisible   = 'Visible';
  rsMaximized = 'Maximized';
  rsData      = 'Data';
  rsSize      = 'Size';

{ TfrxBaseForm }

{$IFDEF DELPHI24}
procedure TfrxBaseForm.ChangeScale(M, D: Integer; isDpiChange: Boolean);
begin
  inherited;
  if M <> D then
  begin
    FNeedUpdatePPI := True;
    DoUpdateFormPPI(D);
  end;
end;
{$ENDIF}

procedure TfrxBaseForm.AfterConstruction;
begin
  inherited;
  //Position := poDefault;
  BeforePPIChange;
  DoUpdateFormPPI(Screen.PixelsPerInch);
  AfterPPIChange;
  if FPrefEvent = peAtCreate then
    ProcessPreferences(frPaLoad);
end;

procedure TfrxBaseForm.AfterPPIChange;
begin
  FIsPPIChanging := False;
end;

procedure TfrxBaseForm.AfterPPIMessage;
begin

end;

procedure TfrxBaseForm.BeforeDestruction;
begin
  inherited;
  if (FPrefEvent in [peAtCreate, peAtShowOnce])  and not FPrefIsSaved then
    ProcessPreferences(frPaSave);
  Setlength(FHostedControls, 0);
end;

procedure TfrxBaseForm.BeforePPIChange;
begin
  FIsPPIChanging := True;
end;

procedure TfrxBaseForm.ChangeScale(M, D: Integer);
begin
  inherited;
  if M <> D then
  begin
    FNeedUpdatePPI := True;
    DoUpdateFormPPI(M);
  end;
end;

constructor TfrxBaseForm.Create(AOwner: TComponent);
begin
  inherited;
  FCurrentFormPPI := 0;
  FNeedUpdatePPI := True;
  FPreferences := GetAvailablePreferences;
  FPrefEvent := peAtShowOnce;
end;

procedure TfrxBaseForm.DoClose(var Action: TCloseAction);
begin
  inherited;
  if (FPrefEvent = peAtShow) or ((FPrefEvent = peAtShowOnce) and not FPrefIsSaved) then
    ProcessPreferences(frPaSave);
end;

procedure TfrxBaseForm.DoShow;
var
  NewPPI: Integer;
  aRect: TRect;
begin
{$IFDEF FPC}
  if csDesigning in ComponentState then
     Exit;
{$ENDIF}
  FormShowBeforeLoad;
  if (FPrefEvent = peAtShow) or ((FPrefEvent = peAtShowOnce) and not FPrefIsLoaded) then
    ProcessPreferences(frPaLoad);
  UpdateResouces;
  if FNeedUpdatePPI and (FSavedPPI = 0) then
    DoUpdateFormPPI(CurrentFormPPI);
//  DoUpdateFormPPI;
  inherited;
  FShowed := True;
  if (FSavedPPI > 0) then
  begin
    NewPPI := FSavedPPI;
    aRect := Rect(Self.Left, Self.Top, Self.Left + Round(Self.Width * NewPPI / Screen.PixelsPerInch), Self.Top + Round(Self.Height * NewPPI / Screen.PixelsPerInch));
    FSavedPPI := 0;
    SendMessage(Self.Handle, FRX_WM_DPICHANGED, MakeWParam(NewPPI, NewPPI), Nativeint(@aRect));
  end;
end;

procedure TfrxBaseForm.DoUpdateFormPPI(aNewPPI: Integer);
begin
  if FNeedUpdatePPI then
  begin
    FNeedUpdatePPI := False;
//{$IFDEF FPC}
//    aNewPPI := frx_DefaultPPI;
//{$ENDIF}
    UpdateFormPPI(aNewPPI);
    FCurrentFormPPI := aNewPPI;
  end;
end;

procedure TfrxBaseForm.FormShowBeforeLoad;
begin

end;

function TfrxBaseForm.GetAvailablePreferences: TfrxPreferencesTypes;
begin
  Result := [];
end;

function TfrxBaseForm.GetCurrentFormPPI: Integer;
begin
  Result := FCurrentFormPPI;
  if Result = 0 then
    Result := Screen.PixelsPerInch;
end;

function TfrxBaseForm.GetFormSectionName: String;
begin
  Result := rsForm + '.' + ClassName;
end;

function TfrxBaseForm.GetPreferencesStorage(aDefault: Boolean): TObject;
begin
  Result := nil;
  { top most windows like designer or preview has access to report Ini file }
  if Assigned(Parent) and (Parent is TfrxBaseForm) then
    Result := TfrxBaseForm(Parent).GetPreferencesStorage(aDefault);
  if (Result = nil) and Assigned(Owner) and (Owner is TfrxBaseForm) then
    Result := TfrxBaseForm(Owner).GetPreferencesStorage(aDefault);
end;

procedure TfrxBaseForm.HostControls(Host: TWinControl);
var
  i: Integer;
begin
  for i := Low(FHostedControls) to High(FHostedControls) do
    FHostedControls[i].Parent := Host;
  UpdateResouces;
  if Assigned(OnShow) then
    OnShow(Self);
end;

function RectInMonitor(aWndRect: TRect): Boolean;
var
  i: Integer;
begin
  Result := False;
  for I := 0 to Screen.MonitorCount - 1 do
    if PtInRect(Screen.Monitors[i].BoundsRect, aWndRect.TopLeft) or
      PtInRect(Screen.Monitors[i].BoundsRect, aWndRect.BottomRight) then
      begin
        Result := True;
        Exit;
      end;
end;


procedure TfrxBaseForm.LoadFormPreferences(PreferencesStorage: TObject; DefPreferencesStorage: TObject);
var
  Ini: TCustomIniFile;
  lName: String;
  lLeft, lTop, lWidth, lHeight: Integer;
  sDock: String;
  cDock: TWinControl;

  procedure ScaleValue(var aVal: Integer; aOriginalVal: Integer);
  begin
    if aOriginalVal <> aVal then
      aVal := Round(aVal * CurrentFormPPI / frx_DefaultPPI)
  end;

begin
  if (PreferencesStorage is TCustomIniFile) then
    Ini := TCustomIniFile(PreferencesStorage)
  else
    Exit;
  lName := GetFormSectionName;
  if FormStyle <> fsMDIChild then
  begin
    if Assigned(DefPreferencesStorage) and not Ini.SectionExists(lName) then
      Ini := TCustomIniFile(DefPreferencesStorage);
    if Ini.ReadBool(lName, rsMaximized, False) then
      WindowState := wsMaximized
    else
    begin
      lLeft := Left;
      lTop := Top;
      lWidth := Width;
      lHeight := Height;
      if frPtFormPos in FPreferences then
      begin
        lLeft := Ini.ReadInteger(lName, rsLeft, lLeft);
        lTop := Ini.ReadInteger(lName, rsTop, lTop);
      end;
      if frPtFormSize in FPreferences then
      begin
        lWidth := Ini.ReadInteger(lName, rsWidth, lWidth);
        lHeight := Ini.ReadInteger(lName, rsHeight, lHeight);
      end;
      if CurrentFormPPI <> Screen.PixelsPerInch then
      begin
        ScaleValue(lLeft, Left);
        ScaleValue(lTop, Top);
      end;
      ScaleValue(lWidth, Width);
      ScaleValue(lHeight, Height);

      if RectInMonitor(Rect(lLeft, lTop, lLeft + lWidth, lTop + lHeight)) then
      begin
        //Position := poDefault;
        SetBounds(lLeft, lTop, lWidth, lHeight);
      end;
    end;
  end;
  if frPtFormDockInfo in FPreferences then
  begin
    sDock := Ini.ReadString(lName, rsDock, '');
    cDock := frxFindComponent(Owner, sDock) as TWinControl;
    if cDock <> nil then
      ManualDock(cDock);
  end;
  if frPtFormVisibility in FPreferences then
    Visible := Ini.ReadBool(lName, rsVisible, True);
end;

procedure TfrxBaseForm.LoadFormPrefType(PreferencesStorage: TObject; DefPreferencesStorage: TObject;
  PrefTyp: TfrxPreferencesTypes);
var
  OldPrefType: TfrxPreferencesTypes;
begin
  OldPrefType := FPreferences;
  try
    FPreferences := PrefTyp;
    FPrefIsLocked := True;
    LoadFormPreferences(PreferencesStorage, DefPreferencesStorage);
  finally
    FPreferences := OldPrefType;
    FPrefIsLocked := False;
  end;
end;

procedure TfrxBaseForm.ProcessPreferences(aPrefArction: TfrxPreferencesAction;
  PrefTyp: TfrxPreferencesTypes);
var
  OldPrefType: TfrxPreferencesTypes;
begin
  OldPrefType := FPreferences;
  try
    FPreferences := PrefTyp;
    ProcessPreferences(aPrefArction);
  finally
    FPreferences := OldPrefType;
  end;
end;

procedure TfrxBaseForm.ProcessPreferences(aPrefArction: TfrxPreferencesAction);
var
  Ini, DefIni: TObject;
begin
  if (FPreferences = []) or FPrefIsLocked then Exit;
  DefIni := GetPreferencesStorage(True);
  Ini := GetPreferencesStorage(False);
  if Ini = nil then Exit;
  try
    FPrefIsLocked := True;
    case aPrefArction of
      frPaLoad:
      begin
        //if Assigned(DefIni) then
        //  LoadFormPreferences(DefIni);
        LoadFormPreferences(Ini, DefIni);
        FPrefIsLoaded := True;
      end;
      frPaSave:
      begin
        try
          SaveFormPreferences(Ini, DefIni);
          FPrefIsSaved := True;
        except
          ResetFormPreferences(Ini);
        end;
      end;
      frPaRestore: ResetFormPreferences(Ini);
    end;
  finally
    FPrefIsLocked := False;
    Ini.Free;
    DefIni.Free;
  end;
end;

procedure TfrxBaseForm.ResetFormPreferences(PreferencesStorage: TObject);
begin

end;

procedure TfrxBaseForm.SaveFormPreferences(PreferencesStorage: TObject; DefPreferencesStorage: TObject);
var
  Ini: TCustomIniFile;
  lName: String;
  lWidth, lHeight: Integer;
begin
  if (PreferencesStorage is TCustomIniFile) then
    Ini := TCustomIniFile(PreferencesStorage)
  else
    Exit;
  lName := GetFormSectionName;
  Ini.WriteInteger(lName, rsLeft, Left);
  Ini.WriteInteger(lName, rsTop, Top);
  lWidth := Round(Width / (CurrentFormPPI / frx_DefaultPPI));
  lHeight := Round(Height / (CurrentFormPPI / frx_DefaultPPI));
  Ini.WriteBool(lName, rsMaximized, WindowState = wsMaximized);
  Ini.WriteBool(lName, rsVisible, Visible);
  if HostDockSite <> nil then
    Ini.WriteString(lName, rsDock, HostDockSite.Name)
  else
    Ini.WriteString(lName, rsDock, '');
  Ini.WriteInteger(lName, rsWidth, lWidth);
  Ini.WriteInteger(lName, rsHeight, lHeight);
end;

procedure TfrxBaseForm.SaveFormPrefType(PreferencesStorage: TObject; DefPreferencesStorage: TObject;
  PrefTyp: TfrxPreferencesTypes);
var
  OldPrefType: TfrxPreferencesTypes;
begin
  OldPrefType := FPreferences;
  try
    FPreferences := PrefTyp;
    SaveFormPreferences(PreferencesStorage, DefPreferencesStorage);
  finally
    FPreferences := OldPrefType;
  end;
end;

{$IFDEF DELPHI24}
procedure TfrxBaseForm.ScaleForPPI(NewPPI: Integer);
begin
  inherited;
  if (NewPPI = FCurrentFormPPI) or (csLoading in ComponentState) then Exit;
  UpdateFormPPI(NewPPI);
  FCurrentFormPPI := NewPPI;
end;
{$ENDIF}

procedure TfrxBaseForm.SendPPIMessage(aWinControl:TWinControl; aNewPPI: Integer);
var
  aRect: TRect;
begin
  if aWinControl is TfrxBaseForm then
    FShowed := True;
  aRect := Rect(aWinControl.Left, aWinControl.Top, aWinControl.Left + Round(aWinControl.Width * aNewPPI / Screen.PixelsPerInch), aWinControl.Top + aWinControl.Height * Round(aNewPPI / Screen.PixelsPerInch));
  SendMessage(aWinControl.Handle, FRX_WM_DPICHANGED, MakeWParam(aNewPPI, aNewPPI), Nativeint(@aRect));
end;

procedure TfrxBaseForm.UnhostControls(AModalResult: TModalResult);
var
  i: Integer;
begin
  ModalResult := AModalResult;
  for i := Low(FHostedControls) to High(FHostedControls) do
    FHostedControls[i].Parent := Self;
  if Assigned(OnHide) then
    OnHide(Self);
end;

procedure TfrxBaseForm.UpdateFormPPI(aNewPPI: Integer);
begin
  frxResources.ImagesPPI := aNewPPI;
end;

procedure TfrxBaseForm.UpdateResouces;
begin

end;

procedure TfrxBaseForm.WMDpiChanged(var Message: TMessage);
//var
//  OldPPI: Integer;
  { look for dock windows }
  procedure DoSendMesssage(aParentControl: TWinControl);
  var
    i: Integer;
  begin
    for i := 0 to aParentControl.ControlCount - 1 do
      if aParentControl.Controls[i] is TForm then
        SendMessage(TForm(aParentControl.Controls[i]).Handle, Message.Msg, Message.WParam, Message.LParam)
      else if aParentControl.Controls[i] is TWinControl then
        DoSendMesssage(TWinControl(aParentControl.Controls[i]));
  end;
var
  lRect: TRect;
  lWParam, lPPI: Integer;
  lMsg: Cardinal;
begin
  if Assigned(FUpdatingPPI) then
  begin
    FUpdatingPPI.Msg := Message.Msg;
    FUpdatingPPI.WParam := Message.WParam;
    FUpdatingPPI.FormRect.Top := PRect(Message.LParam)^.Top;
    FUpdatingPPI.FormRect.Left := PRect(Message.LParam)^.Left;
    FUpdatingPPI.FormRect.Bottom := PRect(Message.LParam)^.Bottom;
    FUpdatingPPI.FormRect.Right := PRect(Message.LParam)^.Right;
    Exit;
  end;
  try
    FUpdatingPPI := TfrxMessageObject.Create;
    FUpdatingPPI.Msg := 0;
    lPPI := HiWord(Message.WParam);

    if not FShowed then
    begin
      FSavedPPI := lPPI; // send message later from FormShow
      Exit;
    end;
    if FCurrentFormPPI <> lPPI then
      BeforePPIChange;
    Inherited;
    if (FCurrentFormPPI <> lPPI) and (FSavedPPI = 0) then
    begin
      // OldPPI := FCurrentFormPPI;
      UpdateFormPPI(lPPI);
{$IFNDEF FPC}
{$IFNDEF DELPHI12}
      DisableAlign;
{$IFNDEF Linux}
      if not(Parent is TWinControl) then
       ChangeScale(Message.WParamHi, FCurrentFormPPI);
{$ENDIF}
      EnableAlign;
      Width := PRect(Message.LParam).Right - PRect(Message.LParam).Left;
      Height := PRect(Message.LParam).Bottom - PRect(Message.LParam).Top;
{$ENDIF}
{$ENDIF}
      FCurrentFormPPI := lPPI;
      UpdateResouces;

      DoSendMesssage(Self);
      AfterPPIChange;
      AfterPPIMessage;
    end;

  finally
    lMsg := FUpdatingPPI.Msg;
    lWParam := FUpdatingPPI.WParam;
    lRect.Top := FUpdatingPPI.FormRect.Top;
    lRect.Left := FUpdatingPPI.FormRect.Left;
    lRect.Right := FUpdatingPPI.FormRect.Right;
    lRect.Bottom := FUpdatingPPI.FormRect.Bottom;
    FreeAndNil(FUpdatingPPI);
    if lMsg = FRX_WM_DPICHANGED then
    begin
      SendMessage(Self.Handle, FRX_WM_DPICHANGED, lWParam, Nativeint(@lRect));
    end;

  end;
end;

{ TfrxBaseLoadSavePrefForm }

function TfrxBaseLoadSavePrefForm.GetAvailablePreferences: TfrxPreferencesTypes;
begin
  Result := [frPtFormPos, frPtFormSize, frPtFormCustom];
end;

end.
