窗体自适应分辨率

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 := 11;

// 1024 x 768
  FontMapping[1].SWidth := 1024;
  FontMapping[1].SHeight := 768;
  FontMapping[1].FName := '宋体';
  FontMapping[1].FSize := 14;

// 1280 x 1024
  FontMapping[2].SWidth := 1280;
  FontMapping[2].SHeight := 1024;
  FontMapping[2].FName := '宋体';
  FontMapping[2].FSize := 16;
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.
 { 引用
procedure TForm1.FormShow(Sender: TObject);
begin
untFixForm.FixForm(Self);
end;
 }