进行屏幕分辨率自适应调整

unit uMyClassHelpers;

interface
uses
SysUtils,
Windows,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
Math,

Typinfo;

const

OriWidth = 800;
OriHeight = 600;

type
TfmForm = class(TForm)
private
fScrResolutionRateW: Double;
fScrResolutionRateH: Double;
fIsFitDeviceDone: Boolean;
procedure FitDeviceResolution;
protected
property IsFitDeviceDone: Boolean read fIsFitDeviceDone;
property ScrResolutionRateH: Double read fScrResolutionRateH;
property ScrResolutionRateW: Double read fScrResolutionRateW;
public
constructor Create(AOwner: TComponent); override;
end;
TfdForm = class(TfmForm)
protected
fIsDlgChange: Boolean;
public
constructor Create(AOwner: TComponent); override;
property IsDlgChange: Boolean read fIsDlgChange default false;
end;
implementation

constructor TfmForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
fScrResolutionRateH := 1;
fScrResolutionRateW := 1;
try
if not fIsFitDeviceDone then
begin
FitDeviceResolution;
fIsFitDeviceDone := True;
end;
except
fIsFitDeviceDone := False;
end;
end;

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 TfmForm.FitDeviceResolution;
var
LocList : TList;
LocFontRate : Double;
LocFontSize : Integer;
LocFont : TFont;
locK : Integer;

procedure CalBasicScalePars;
begin
try
Self.Scaled := False;
fScrResolutionRateH := screen.height / OriHeight;
fScrResolutionRateW := screen.Width / OriWidth;
LocFontRate := Min(fScrResolutionRateH, fScrResolutionRateW);
except
raise;
end;
end;

procedure ControlsPostoList(vCtl: TControl; vList: TList);
var
locPRect : ^TRect;
i : Integer;
locCtl : TControl;
begin
try
New(locPRect);
locPRect^ := vCtl.BoundsRect;
vList.Add(locPRect);
if vCtl is TWinControl then
for i := 0 to TWinControl(vCtl).ControlCount – 1 do
begin
locCtl := TWinControl(vCtl).Controls[i];
ControlsPosToList(locCtl, vList);
end;
except
raise;
end;
end;

procedure AdjustControlsScale(vCtl: TControl; vList: TList; var vK: Integer);
var
locOriRect, LocNewRect: TRect;
i : Integer;
locCtl : TControl;
begin
try
if vCtl.Align alClient then
begin
locOriRect := TRect(vList.Items[vK]^);
with locNewRect do
begin
Left := Round(locOriRect.Left * fScrResolutionRateW);
Right := Round(locOriRect.Right * fScrResolutionRateW);
Top := Round(locOriRect.Top * fScrResolutionRateH);
Bottom := Round(locOriRect.Bottom * fScrResolutionRateH);
vCtl.SetBounds(Left, Top, Right – Left, Bottom – Top);
end;
end;
Inc(vK);
if vCtl is TWinControl then
for i := 0 to TwinControl(vCtl).ControlCount – 1 do
begin
locCtl := TWinControl(vCtl).Controls[i];
AdjustControlsScale(locCtl, vList, vK);
end;
except
raise;
end;
end;

procedure AdjustComponentFont(vCmp: TComponent);
var
i : Integer;
locCmp : TComponent;
begin
try
for i := vCmp.ComponentCount – 1 downto 0 do
begin
locCmp := vCmp.Components[i];
if PropertyExists(LocCmp, ‘FONT’) then
begin
LocFont := TFont(GetObjectProperty(LocCmp, ‘FONT’));
LocFontSize := Round(LocFontRate * LocFont.Size);
LocFont.Size := LocFontSize;
end;
end;
except
raise;
end;
end;

procedure FreeListItem(vList: TList);
var
i : Integer;
begin
for i := 0 to vList.Count – 1 do
Dispose(vList.Items[i]);
vList.Free;
end;
begin
LocList := TList.Create;
try
try
if (Screen.width OriWidth) or (Screen.Height OriHeight) then
begin
CalBasicScalePars;
AdjustComponentFont(Self);
ControlsPostoList(Self, locList);
locK := 0;
AdjustControlsScale(Self, locList, locK);
end;
except on E: Exception do
raise Exception.Create(‘进行屏幕分辨率自适应调整时出现错误’ +
E.Message);
end;
finally
FreeListItem(locList);
end;
end;

constructor TfdForm.Create(AOwner: TComponent);
begin
inherited;
fIsDlgChange := False;
end;
end.