(转) 实现窗体自适应调整尺寸以适应不同屏幕分辩率

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

经测试代码可用！

 

uMyClassHelpers

 

  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.
View Code

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

经测试代码可用！

uMyClassHelpers

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