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.