Delphi 让窗体自适应屏幕显示

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.