unit Unit1;

interface

uses

Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,

Vcl.Controls, Vcl.Forms, Vcl.Dialogs,Typinfo, Vcl.StdCtrls;

type

TForm1 = class(TForm)

Button1: TButton;

procedure FormCreate(Sender: TObject);

procedure Button1Click(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Form1: TForm1;

implementation

{$R *.dfm}

function PropertyExists(const AObject: TObject; const APropName: string): Boolean;

var

PropInfo: PPropInfo;

begin

PropInfo := GetPropInfo(AObject.ClassInfo, APropName);

Result := Assigned(PropInfo);

end;

function GetObjectProperty(

const AObject: TObject;

const APropName: string

): TObject;

var

PropInfo: PPropInfo;

begin

Result := nil;

PropInfo := GetPropInfo(AObject.ClassInfo, APropName);

if Assigned(PropInfo) and

(PropInfo^.PropType^.Kind = tkClass) then

Result := GetObjectProp(AObject, PropInfo);

end;

procedure FitDeviceResolution(Sender: TForm);

const

OriWidth = 1440;

OriHeight = 900;

var

i: Integer;

j: Integer;

LocAnchors: array of TAnchors;

LocAlign: array of TAlign;

LocList: TList;

LocFontSize: Integer;

LocFont: TFont;

LocCmp: TComponent;

ScrResolutionRateH, ScrResolutionRateW,LocFontRate: Double;

begin

ScrResolutionRateH := Screen.Height / OriHeight;

ScrResolutionRateW := Screen.Width / OriWidth;

if Abs(ScrResolutionRateH - 1) < Abs(ScrResolutionRateW - 1) then

LocFontRate := ScrResolutionRateH

else

LocFontRate := ScrResolutionRateW;

LocList := TList.Create;

try

try

if (screen.width <> OriWidth) or (screen.Height <> OriHeight) then

begin

Sender.Scaled := False;

for i := Sender.ComponentCount - 1 downto 0 do

begin

LocCmp := Sender.Components[i];

if LocCmp is TControl then

LocList.Add(LocCmp);

if PropertyExists(LocCmp, 'FONT') then

begin

LocFont := TFont(GetObjectProperty(LocCmp, 'FONT'));

LocFontSize := Round(LocFontRate * LocFont.Size);

LocFont.Size := LocFontSize;

end;

end;

SetLength(LocAnchors, LocList.Count);

SetLength(LocAlign, LocList.Count);

for i := 0 to LocList.Count - 1 do

with TControl(LocList.Items[i]) do

begin

LocAnchors[i] := Anchors;

LocAlign[i] := Align;

Align := alNone;

Anchors := [akLeft, akTop];

end;

Sender.Top := Round(Sender.Top * ScrResolutionRateH);

Sender.Left := Round(Sender.Left * ScrResolutionRateW);

Sender.Height := Round(Sender.Height * ScrResolutionRateH);

Sender.Width := Round(Sender.Width * ScrResolutionRateW);

Sender.Font.size := Round(LocFontRate * Sender.Font.size);

for i := 0 to LocList.Count - 1 do

begin

with TControl(LocList.Items[i]) do

begin

Top := Round(Top * ScrResolutionRateH);

Left := Round(Left * ScrResolutionRateW);

Height := Round(height * ScrResolutionRateH);

Width := Round(width * ScrResolutionRateW);

end;

end;

for i := 0 to LocList.Count - 1 do

TControl(LocList.Items[i]).Align := LocAlign[i];

for i := 0 to LocList.Count - 1 do

TControl(LocList.Items[i]).Anchors := LocAnchors[i];

end;

except

MessageDlg(LocCMP.Name, mtInformation, [mbOK], 0);

end;

finally

LocList.Free;

end;

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

FitDeviceResolution(Self);

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

FitDeviceResolution(Self);

end;

end.