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;
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)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);
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;
Procedure TfmForm.ControlsPostoList(vCtl:TControl;vList:TList);
Var
locPRect:^TRect;
i:Integer;
locCtl:TControl;
Begin
try
New(locPRect);
locPRect^:=vCtl.BoundsRect;
vList.Add(locPRect);
If vCtl Is TWinControl Then
For i:=0 to TWinControl(vCtl).ControlCount-1 Do
begin
locCtl:=TWinControl(vCtl).Controls;
ControlsPosToList(locCtl,vList);
end;
except
Raise;
end;
End;
Procedure TfmForm.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;
Inc(vK);
If vCtl Is TWinControl Then
For i:=0 to TwinControl(vCtl).ControlCount-1 Do
begin
locCtl:=TWinControl(vCtl).Controls;
AdjustControlsScale(locCtl,vList,vK);
end;
except
Raise;
end;
End;
Procedure TfmForm.AdjustComponentFont(vCmp:TComponent);
Var
i:Integer;
locCmp:TComponent;
Begin
try
For i:=vCmp.ComponentCount-1 Downto 0 Do
Begin
locCmp:=vCmp.Components;
If PropertyExists(LocCmp,'FONT') Then
Begin
LocFont:=TFont(GetObjectProperty(LocCmp,'FONT'));
LocFontSize := Round(LocFontRate*LocFont.Size);
LocFont.Size:=LocFontSize;
End;
End;
except
Raise;
end;
End;
Procedure TfmForm.FreeListItem(vList:TList);
Var
i:Integer;
Begin
For i:=0 to vList.Count-1 Do
Dispose(vList.Items);
vList.Free;
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;
function TfmForm.PropertyExists(const AObject: TObject;const APropName:String):Boolean;
//判断一个属性是否存在
var
PropInfo:PPropInfo;
begin
PropInfo:=GetPropInfo(AObject.ClassInfo,APropName);
Result:=Assigned(PropInfo);
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;
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;
再次表示谢意!
zhaoyazhe888888@sohu.com