让窗体自适应屏幕
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.