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, );

// 800 x 600

FontMapping[].SWidth := ;

FontMapping[].SHeight := ;

FontMapping[].FName := '宋体';

FontMapping[].FSize := ;

// 1024 x 768

FontMapping[].SWidth := ;

FontMapping[].SHeight := ;

FontMapping[].FName := '宋体';

FontMapping[].FSize := ;

// 1280 x 1024

FontMapping[].SWidth := ;

FontMapping[].SHeight := ;

FontMapping[].FName := '宋体';

FontMapping[].FSize := ;

end;

procedure FixForm(AForm:TForm);

var

i, j:integer;

t:TControl;

begin

with AForm do

begin

    for i :=  to ComponentCount -  do

    begin

      try

        t := TControl(Components[i]);

        t.left := Trunc(t.left * (Screen.width / ));

        t.top := Trunc(t.Top * (Screen.Height / ));

        t.Width := Trunc(t.Width * (Screen.Width / ));

        t.Height := Trunc(t.Height * (Screen.Height / ));

      except

      end; { try }

    end; { for i }

    for i :=  to Length(FontMapping) -  do

    begin

      if (Screen.Width = FontMapping[i].SWidth) and (Screen.Height =

        FontMapping[i].SHeight) then

      begin

        for j :=  to ComponentCount -  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.

procedure TForm1.FormShow(Sender:TObject);

begin

if MessageBox(Handle, '要使用屏幕自适应吗？', '提示', MB_YESNO or

    MB_ICONINFORMATION) = idno then Exit;

untFixForm.FixForm(Self);

end;