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.
Delphi自动适应屏幕分辨率的属性的更多相关文章
- delphi 窗体自适应屏幕分辨率
delphi 窗体自适应屏幕分辨率 这是个困惑我很长时间的问题,到今天终于得到解决了. 话说Delphi有个很强的窗体设计器,这一点让VC粉丝垂涎三尺而不可得.但是,Delphi里设计的窗体并没有自动 ...
- delphi 动态更改屏幕分辨率(转)
一.如何动态更改屏幕分辨率 有许多小工具可以在不重新启动Windows的条件下,动态更改屏幕分辨率.你是不是也想自己动手做一个呢?请在interface段中加入下面一句 function Resolu ...
- RS报表自动适应屏幕分辨率大小
问题:同一个报表,由于用户电脑显示器大小,分辨率大小不同显示的不一样,看起来不完整或者很不协调 原因:设计报表大小属性的时候使用了固定值属性,比如限制为宽:1200px 那么在电脑屏幕小分辨率很小的情 ...
- Silverlight自动根据屏幕分辨率进行布局
xaml: <UserControl x:Class="SLCenterLayout.MainPage" xmlns="http://schemas.microso ...
- Delphi:窗体自适应屏幕分辨率(根据预设值的比例改变)
delphi 程序适应屏幕分辨率,先在表单单元的Interface部分定义两个常量, 表示设计时的屏幕的宽度和高度(以像素为单位). 在表单的Create事件中先判断 当前分辨率是否与设计分辨率相同, ...
- Delphi:窗体自适应屏幕分辨率的改进
在窗体依据屏幕分辨率自适应调整尺度方面,昨天的工作可以说是一个突破点.昨天的工作找到了长期以来我的原有方案的问题所在,这是非常关键的.但是昨天晚上的解决方案并不完美,今天的这个才是比较完美的解决版. ...
- CSS根据屏幕分辨率宽度自动适应的办法
CSS根据屏幕分辨率宽度自动适应的办法 第一种办法是js选择CSS <SCRIPT language=JavaScript><!-- Beginif (screen.width == ...
- Unity3D NGUI自适应屏幕分辨率(2014/4/17更新)
原地址:http://blog.csdn.net/asd237241291/article/details/8126619 原创文章如需转载请注明:转载自 脱莫柔Unity3D学习之旅 本文链接地址: ...
- WPF 获取屏幕分辨率(获取最大宽高)等
double x = SystemParameters.WorkArea.Width;//得到屏幕工作区域宽度 double y = SystemParameters.WorkArea.Height; ...
随机推荐
- CentOS下设置vim的tab键为4格
# vim /etc/vimrc 在最后一行添加 set softtabstop=4 或者set tabstop=4 或者在~/.vimrc中添加也可以 没有~/.vimrc文件可以创建一个 另: s ...
- 流媒体技术学习笔记之(十七)FFmpeg 3.3《希尔伯特》-新版本的亮点
FFmpeg 3.3“Hilbert”,一个新的主要版本的一些亮点: 苹果Pixlet解码器 NewTek SpeedHQ解码器 QDMC音频解码器 PSD(Photoshop Document)解码 ...
- PHP7 学习笔记(三)关于PHP7如何安装调试工具Xdebug扩展以及Zephir的问题
前言: 1.自己摸索安装 2.快速安装 安装这个扩展是由于Zephir 编译不能始终通过,迫不得已啊,使用Zephir写扩展,总是出现以下错误: www@ubuntu1:~/phalcon-zephi ...
- IDEA 实用功能Auto Import:自动优化导包(自动删除、导入包)
JetBrains公司的intellij Idea堪称JAVA编程界的苹果,用户体验非常好 下面介绍一下IDEA的一个能显著提升写代码效率的非常好用的功能设置—— Auto Import Auto I ...
- 键盘按键js效果
<input id="name" type="text" > JS: <script> document.onkeydown = fun ...
- D - 文理分科 (网络流->最小割)
题目链接:https://cn.vjudge.net/contest/281959#problem/D 题目大意:中文题目 具体思路:我们需要求出最大的满意值,从另一方面想,我们可以求出总的满意值,然 ...
- activity 解析
acitvity的四种状态: running.paused.stopped.killed 生命周期: onCreate()用来加载资源布局 onStart()启动activity,用户已经可以看到界面 ...
- win10 + ubuntu双系统详细安装过程
由于搞深度学习,电脑跟不上,换了一台神舟战神Z8,于是装一个ubuntu双系统,没想到几乎花了一天,还花了80个软妹币找人帮忙,蓝瘦,现在写下来供大家参考: 不得不说,win10 + ubuntu双系 ...
- 用nodejs做一下发送邮件例子
var nodemailer = require("nodemailer"); var transport = nodemailer.createTransport("S ...
- notepad++64位添加plugin manager
- 64位的notepad++,下载下来似乎没有plugin manager,如果真没有可以下载plugin manager. - plugin manager的下载地址:https://github ...