unit untFixForm; interface uses Classes, SysUtils, Controls, Forms; type TFontedControl = class(TControl) public property Font; end; TFontMapping = record SWidth:Integer; SHeight:Integer; FName:string; FSize:Integer; end; procedure FixForm(AForm:TForm); procedure SetFontMapping; var FontMapping:array of TFontMapping; implementation procedure SetFontMapping; begin SetLength(FontMapping, 3); // 800 x 600 FontMapping[0].SWidth := 800; FontMapping[0].SHeight := 600; FontMapping[0].FName := ‘宋体‘; FontMapping[0].FSize := 7; // 1024 x 768 FontMapping[1].SWidth := 1024; FontMapping[1].SHeight := 768; FontMapping[1].FName := ‘宋体‘; FontMapping[1].FSize := 9; // 1280 x 1024 FontMapping[2].SWidth := 1280; FontMapping[2].SHeight := 1024; FontMapping[2].FName := ‘宋体‘; FontMapping[2].FSize := 11; end; procedure FixForm(AForm:TForm); var i, j:integer; t:TControl; begin with AForm do begin for i := 0 to ComponentCount - 1 do begin try t := TControl(Components[i]); t.left := Trunc(t.left * (Screen.width / 1024)); t.top := Trunc(t.Top * (Screen.Height / 768)); t.Width := Trunc(t.Width * (Screen.Width / 1024)); t.Height := Trunc(t.Height * (Screen.Height / 768)); except end; { try } end; { for i } for i := 0 to Length(FontMapping) - 1 do begin if (Screen.Width = FontMapping[i].SWidth) and (Screen.Height = FontMapping[i].SHeight) then begin for j := 0 to ComponentCount - 1 do begin try TFontedControl(Components[j]).Font.Name := FontMapping[i].FName; TFontedControl(Components[j]).FONT.Size := FontMapping[i].FSize; except end; { try } end; { for j } end; { if } end; { for i } end; { with } end; initialization SetFontMapping; end.
SetFontMapping 方法可以自行修改,以适应更多的分辨率。
调用也非常简单,如下所示:
procedure TForm1.FormShow(Sender:TObject); begin if MessageBox(Handle, ‘要使用屏幕自适应吗?‘, ‘提示‘, MB_YESNO or MB_ICONINFORMATION) = idno then Exit; untFixForm.FixForm(Self); end;
http://blog.csdn.net/han_348154920/article/details/4762928
时间: 2024-09-30 17:31:14