下面包括两个类,一个是普通窗体类,一个是其子类对话框型窗体类。在实际应用过程中只要自己创建的窗体类继承自以上两个类中的一个,例如 TForm1 = class(TfdForm),则不需添加任何源码,设计出窗体会自动调整其上控件的尺寸,以适应不同的屏幕分辨率。
经测试代码可用!
uMyClassHelpers
![](https://i-blog.csdnimg.cn/blog_migrate/8f900a89c6347c561fdf2122f13be562.gif)
![](https://i-blog.csdnimg.cn/blog_migrate/961ddebeb323a10fe0623af514929fc1.gif)
1 unit AutoResolution; 2 3 interface 4 uses 5 SysUtils, Windows, Classes, Graphics, Controls, Forms, Dialogs, Math, 6 TypInfo; 7 8 const //记录设计时的屏幕分辨率 9 OriWidth = 1024; 10 OriHeight = 768; 11 12 type 13 14 TfmForm = class(TForm) //实现窗体屏幕分辨率的自动调整 15 private 16 fScrResolutionRateW: Double; 17 fScrResolutionRateH: Double; 18 fIsFitDeviceDone: Boolean; 19 procedure FitDeviceResolution; 20 protected 21 property IsFitDeviceDone: Boolean read fIsFitDeviceDone; 22 property ScrResolutionRateH: Double read fScrResolutionRateH; 23 property ScrResolutionRateW: Double read fScrResolutionRateW; 24 public 25 constructor Create(AOwner: TComponent); override; 26 function PropertyExists(const AObject: TObject;const APropName:String):Boolean; 27 function GetObjectProperty( 28 const AObject : TObject; 29 const APropName : string 30 ):TObject; 31 end; 32 33 TfdForm = class(TfmForm) //增加对话框窗体的修改确认 34 protected 35 fIsDlgChange: Boolean; 36 public 37 constructor Create(AOwner: TComponent); override; 38 property IsDlgChange: Boolean read fIsDlgChange default false; 39 end; 40 41 implementation 42 43 function TfmForm.PropertyExists(const AObject: TObject;const APropName:String):Boolean; 44 //判断一个属性是否存在 45 var 46 PropInfo:PPropInfo; 47 begin 48 PropInfo:=GetPropInfo(AObject.ClassInfo,APropName); 49 Result:=Assigned(PropInfo); 50 end; 51 52 function TfmForm.GetObjectProperty( 53 const AObject : TObject; 54 const APropName : string 55 ):TObject; 56 var 57 PropInfo:PPropInfo; 58 begin 59 Result := nil; 60 PropInfo:=GetPropInfo(AObject.ClassInfo,APropName); 61 if Assigned(PropInfo) and 62 (PropInfo^.PropType^.Kind = tkClass) then 63 Result := GetObjectProp(AObject,PropInfo); 64 end; 65 66 constructor TfmForm.Create(AOwner: TComponent); 67 begin 68 inherited Create(AOwner); 69 fScrResolutionRateH := 1; 70 fScrResolutionRateW := 1; 71 try 72 if not fIsFitDeviceDone then 73 begin 74 FitDeviceResolution; 75 fIsFitDeviceDone := True; 76 end; 77 except 78 fIsFitDeviceDone := False; 79 end; 80 end; 81 82 procedure TfmForm.FitDeviceResolution; 83 var 84 LocList: TList; 85 LocFontRate: Double; 86 LocFontSize: Integer; 87 LocFont: TFont; 88 locK: Integer; 89 {计算尺度调整的基本参数} 90 procedure CalBasicScalePars; 91 begin 92 try 93 Self.Scaled := False; 94 fScrResolutionRateH := screen.height / OriHeight; 95 fScrResolutionRateW := screen.Width / OriWidth; 96 LocFontRate := Min(fScrResolutionRateH, fScrResolutionRateW); 97 except 98 raise; 99 end; 100 end; 101 102 {保存原有坐标位置:利用递归法遍历各级容器里的控件,直到最后一级} 103 procedure ControlsPostoList(vCtl: TControl; vList: TList); 104 var 105 locPRect: ^TRect; 106 i: Integer; 107 locCtl: TControl; 108 locFontp: ^Integer; 109 begin 110 try 111 New(locPRect); 112 locPRect^ := vCtl.BoundsRect; 113 vList.Add(locPRect); 114 if PropertyExists(vCtl, 'FONT') then 115 begin 116 LocFont := TFont(GetObjectProperty(vCtl, 'FONT')); 117 New(locFontp); 118 locFontP^ := LocFont.Size; 119 vList.Add(locFontP); 120 // ShowMessage(vCtl.Name+'Ori:='+InttoStr(LocFont.Size)); 121 end; 122 if vCtl is TWinControl then 123 for i := 0 to TWinControl(vCtl).ControlCount - 1 do 124 begin 125 locCtl := TWinControl(vCtl).Controls[i]; 126 ControlsPosToList(locCtl, vList); 127 end; 128 except 129 raise; 130 end; 131 end; 132 133 {计算新的坐标位置:利用递归法遍历各级容器里的控件,直到最后一层。 134 计算坐标时先计算顶级容器级的,然后逐级递进} 135 procedure AdjustControlsScale(vCtl: TControl; vList: TList; var vK: Integer); 136 var 137 locOriRect, LocNewRect: TRect; 138 i: Integer; 139 locCtl: TControl; 140 begin 141 try 142 if vCtl.Align <> alClient then 143 begin 144 locOriRect := TRect(vList.Items[vK]^); 145 with locNewRect do 146 begin 147 Left := Round(locOriRect.Left * fScrResolutionRateW); 148 Right := Round(locOriRect.Right * fScrResolutionRateW); 149 Top := Round(locOriRect.Top * fScrResolutionRateH); 150 Bottom := Round(locOriRect.Bottom * fScrResolutionRateH); 151 vCtl.SetBounds(Left, Top, Right - Left, Bottom - Top); 152 end; 153 end; 154 if PropertyExists(vCtl, 'FONT') then 155 begin 156 Inc(vK); 157 LocFont := TFont(GetObjectProperty(vCtl, 'FONT')); 158 locFontSize := Integer(vList.Items[vK]^); 159 LocFont.Size := Round(LocFontRate * locFontSize); 160 // ShowMessage(vCtl.Name+'New:='+InttoStr(LocFont.Size)); 161 end; 162 Inc(vK); 163 if vCtl is TWinControl then 164 for i := 0 to TwinControl(vCtl).ControlCount - 1 do 165 begin 166 locCtl := TWinControl(vCtl).Controls[i]; 167 AdjustControlsScale(locCtl, vList, vK); 168 end; 169 except 170 raise; 171 end; 172 end; 173 174 {释放坐标位置指针和列表对象} 175 procedure FreeListItem(vList: TList); 176 var 177 i: Integer; 178 begin 179 for i := 0 to vList.Count - 1 do 180 Dispose(vList.Items[i]); 181 vList.Free; 182 end; 183 184 begin 185 LocList := TList.Create; 186 try 187 try 188 if (Screen.width <> OriWidth) or (Screen.Height <> OriHeight) then 189 begin 190 CalBasicScalePars; 191 // AdjustComponentFont(Self); 192 ControlsPostoList(Self, locList); 193 locK := 0; 194 AdjustControlsScale(Self, locList, locK); 195 196 end; 197 except on E: Exception do 198 raise Exception.Create('进行屏幕分辨率自适应调整时出现错误' + E.Message); 199 end; 200 finally 201 FreeListItem(locList); 202 end; 203 end; 204 205 206 { TfdForm } 207 208 constructor TfdForm.Create(AOwner: TComponent); 209 begin 210 inherited; 211 fIsDlgChange := False; 212 end; 213 214 end.
下面包括两个类,一个是普通窗体类,一个是其子类对话框型窗体类。在实际应用过程中只要自己创建的窗体类继承自以上两个类中的一个,例如 TForm1 = class(TfdForm),则不需添加任何源码,设计出窗体会自动调整其上控件的尺寸,以适应不同的屏幕分辨率。
经测试代码可用!
uMyClassHelpers
- <pre name="code" class="delphi">unit uMyClassHelpers;
- {实现窗体自适应调整尺寸以适应不同屏幕分辩率的显示问题。
- 陈小斌,2012年3月5日
- 使用时,主窗体直接继承TfdForm Tform1=class(TfdForm)
- 或TfmForm Tform1=class(TfmForm)即可
- -----haiou327测试 }
- interface
- uses
- SysUtils, Windows, Classes, Graphics, Controls, Forms, Dialogs, Math,
- TypInfo;
- const //记录设计时的屏幕分辨率
- OriWidth = 1024;
- OriHeight = 768;
- 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;
- function PropertyExists(const AObject: TObject;const APropName:String):Boolean;
- function GetObjectProperty(
- const AObject : TObject;
- const APropName : string
- ):TObject;
- end;
- TfdForm = class(TfmForm) //增加对话框窗体的修改确认
- protected
- fIsDlgChange: Boolean;
- public
- constructor Create(AOwner: TComponent); override;
- property IsDlgChange: Boolean read fIsDlgChange default false;
- end;
- implementation
- function TfmForm.PropertyExists(const AObject: TObject;const APropName:String):Boolean;
- //判断一个属性是否存在
- var
- PropInfo:PPropInfo;
- begin
- PropInfo:=GetPropInfo(AObject.ClassInfo,APropName);
- Result:=Assigned(PropInfo);
- end;
- function TfmForm.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.</pre>
- <pre></pre>
- <pre></pre>