Delphi自动适应屏幕分辨率的属性

https://www.cnblogs.com/zhangzhifeng/category/835602.html

这是个困惑我很长时间的问题，到今天终于得到解决了。

话说Delphi有个很强的窗体设计器，这一点让VC粉丝垂涎三尺而不可得。但是，Delphi里设计的窗体并没有自动适应屏幕分辨率的属性,也就是说，软件设计时调整完美的窗体控件布局，在不同屏幕分辨率的机器上运行时可能会变得面目全非。控件之间会相互移位，有的甚至移出窗体再也找不到了。

这个问题在网上搜索过多次，但大都依据控件方法ScaleBy或者ChangeScale。采用这两个方法进行自适应调整，我自己都试过，但效果并不理想。后来我自己也写了一个继承自窗体的基类，覆盖构造函数，调用自己的一个设备分辨率自适应方法，该方法遍历窗体上所有控件，并按照设计时的屏幕分辨率和当前屏幕分辨率的比值，逐一计算控件的位置和尺寸。这个想法是不错，效果也是有的，比单纯的采用ScaleBy或者ChangeScale方法要好，但也不是非常理想，没有达到自己设想的要求。原因在哪里，一直不知道。

我原来的代码曾经发布在Delphi盒子和CSDN上。

这个问题今天终于得以彻底解决了！！

原因是，我原以为将所有控件的Align属性设为alnone，Anchors属性设为空[]，控件位置和尺寸就不会受其容器尺寸改变的影响。今天我在设计期对此进行试验时，发现不是这样。当窗体大小改变的时候，即使某个控件的Align:=alNone,Anchors:=[],它依然会随着窗体尺度的变化而变化。这意味着我需要一个数组事先保存所有控件的原始位置和尺寸。在窗体因为屏幕分辨率的改变而自动调整时，计算的依据依然是不变的原始窗体位置尺寸数据，这样问题就解决了。

闲话少说，上源码。

unit uMyClassHelpers;

interface

Uses

  SysUtils,Windows,Classes,Graphics, Controls,Forms,Dialogs,
  uMySysUtils;

Const   //记录设计时的屏幕分辨率

  OriWidth=1366;
  OriHeight=768;

Type

  TfmForm=Class(TForm)   //实现窗体屏幕分辨率的自动调整
  Private
    fScrResolutionRateW: Double;
    fScrResolutionRateH: Double;
    fIsFitDeviceDone: Boolean;
    fPosition:Array of TRect;
    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;

procedure TfmForm.FitDeviceResolution;
Var
  i:Integer;
  LocList:TList;
  LocFontSize:Integer;
  LocFont:TFont;
  LocCmp:TComponent;
  LocFontRate:Double;
  LocRect:TRect;
  LocCtl:TControl;
begin
  LocList:=TList.Create;
  Try
    Try
      if (Screen.width<>OriWidth)OR(Screen.Height<>OriHeight) then
      begin
        Self.Scaled:=False;
        fScrResolutionRateH:=screen.height/OriHeight;
        fScrResolutionRateW:=screen.Width/OriWidth;
        Try
          if fScrResolutionRateH<fScrResolutionRateW then
            LocFontRate:=fScrResolutionRateH
          Else
            LocFontRate:=fScrResolutionRateW;
        Finally
          ReleaseDC(0, GetDc(0));
        End;

        For i:=Self.ComponentCount-1 Downto 0 Do
        Begin
          LocCmp:=Self.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(fPosition,LocList.Count+1);
        For i:=0 to LocList.Count-1 Do
          With TControl(LocList.Items[i])Do
            fPosition[i+1]:=BoundsRect;
        fPosition[0]:=Self.BoundsRect;

        With LocRect Do
        begin
           Left:=Round(fPosition[0].Left*fScrResolutionRateW);
           Right:=Round(fPosition[0].Right*fScrResolutionRateW);
           Top:=Round(fPosition[0].Top*fScrResolutionRateH);
           Bottom:=Round(fPosition[0].Bottom*fScrResolutionRateH);
           Self.SetBounds(Left,Top,Right-Left,Bottom-Top);
        end;

        i:= LocList.Count-1;
        While (i>=0) Do
         Begin
          LocCtl:=TControl(LocList.Items[i]);
          If LocCtl.Align=alClient Then
          begin
            Dec(i);
            Continue;
          end;
          With LocRect Do
          begin
             Left:=Round(fPosition[i+1].Left*fScrResolutionRateW);
             Right:=Round(fPosition[i+1].Right*fScrResolutionRateW);
             Top:=Round(fPosition[i+1].Top*fScrResolutionRateH);
             Bottom:=Round(fPosition[i+1].Bottom*fScrResolutionRateH);
             LocCtl.SetBounds(Left,Top,Right-Left,Bottom-Top);
          end;
          Dec(i);
        End;
      End;

    Except on E:Exception Do
      Raise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);
    End;
  Finally
    LocList.Free;
  End;
end;

{ TfdForm }

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

end.

上面包括两个类，一个是普通窗体类，一个是其子类对话框型窗体类。在实际应用过程中只要自己创建的窗体类继承自以上两个类中的一个，例如 TForm1 = class(TfdForm)，则不需添加任何源码，设计出窗体会自动调整其上控件的尺寸，以适应不同的屏幕分辨率。

以上源码经过验证，效果非常好，解决了一个多年未决的问题！

unit uMyClassHelpers;
{实现窗体自适应调整尺寸以适应不同屏幕分辩率的显示问题。
使用说明：
但你自己可以随便就做一个例子。
新建一个窗体，把新窗体继承的类TForm改成TfmForm或者TfdForm，
然后随便拖一些控件在窗体，改变OriWidth和OriHeight的值来模拟设计时屏幕分辨率，
或者改变自己电脑的屏幕分辨率来模拟实际情况，就可以很方便地演示窗体的自适应变化。
整个过程不需要手工添加一条源码。
}

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

const //记录设计时的屏幕分辨率
  OriWidth = 1920;
  OriHeight = 1080;

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


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;



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;

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;
    locFontp: ^Integer;
  begin
    try
      New(locPRect);
      locPRect^ := vCtl.BoundsRect;
      vList.Add(locPRect);
      if PropertyExists(vCtl, 'FONT') then
      begin
        LocFont := TFont(GetObjectProperty(vCtl, 'FONT'));
        New(locFontp);
        locFontP^ := LocFont.Size;
        vList.Add(locFontP);
//        ShowMessage(vCtl.Name+'Ori:='+InttoStr(LocFont.Size));
      end;
      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;
      if PropertyExists(vCtl, 'FONT') then
      begin
        Inc(vK);
        LocFont := TFont(GetObjectProperty(vCtl, 'FONT'));
        locFontSize := Integer(vList.Items[vK]^);
        LocFont.Size := Round(LocFontRate * locFontSize);
//        ShowMessage(vCtl.Name+'New:='+InttoStr(LocFont.Size));
      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 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;


{ TfdForm }

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

end.