程序窗体及控件自适应分辨率

 

1. 代码如下：
3. unit untFixForm;
5. interface
7. uses
8. Classes, SysUtils, Controls, Forms;
10. type
11. TFontedControl = class(TControl)
12. public
13.     property Font;
14. end;
16. TFontMapping = record
17.     SWidth : Integer;
18.     SHeight: Integer;
19.     FName: string;
20.     FSize: Integer;
21. end;
23. procedure FixForm(AForm: TForm);
24. procedure SetFontMapping;
26. var
27. FontMapping : array of TFontMapping;
29. implementation
31. procedure SetFontMapping;
32. begin
33. SetLength(FontMapping, 3);
35. // 800 x 600
36. FontMapping[0].SWidth := 800;
37. FontMapping[0].SHeight := 600;
38. FontMapping[0].FName := '宋体';
39. FontMapping[0].FSize := 7;
41. // 1024 x 768
42. FontMapping[1].SWidth := 1024;
43. FontMapping[1].SHeight := 768;
44. FontMapping[1].FName := '宋体';
45. FontMapping[1].FSize := 9;
47. // 1280 x 1024
48. FontMapping[2].SWidth := 1280;
49. FontMapping[2].SHeight := 1024;
50. FontMapping[2].FName := '宋体';
51. FontMapping[2].FSize := 11;
53. end;
55. procedure FixForm(AForm: TForm);
56. var
57. i, j                 : integer;
58. t                 : TControl;
59. begin
60. with AForm do
61. begin
62.     for i := 0 to ComponentCount - 1 do
63.     begin
64.       try
65.         t := TControl(Components[i]);
66.         t.left := Trunc(t.left * (Screen.width / 1024));
67.         t.top := Trunc(t.Top * (Screen.Height / 768));
68.         t.Width := Trunc(t.Width * (Screen.Width / 1024));
69.         t.Height := Trunc(t.Height * (Screen.Height / 768));
70.       except
71.       end; { try }
72.     end; { for i }
74.     for i:= 0 to Length(FontMapping) - 1 do
75.     begin
76.       if (Screen.Width = FontMapping[i].SWidth) and (Screen.Height = FontMapping[i].SHeight) then
77.       begin
78.         for j := 0 to ComponentCount - 1 do
79.         begin
80.           try
81.             TFontedControl(Components[j]).Font.Name := FontMapping[i].FName;
82.             TFontedControl(Components[j]).FONT.Size := FontMapping[i].FSize;
83.           except
84.           end; { try }
85.         end; { for j }
86.       end; { if }
87.     end; { for i }
88. end; { with }
89. end;
91. initialization
92. SetFontMapping;
94. end.
96. SetFontMapping 方法可以自行修改，以适应更多的分辨率。
98. 调用也非常简单，如下所示：
99. procedure TForm1.FormShow(Sender: TObject);
100. begin
101. if MessageBox(Handle,'要使用屏幕自适应吗？','提示',MB_YESNO or MB_ICONINFORMATION) = idno then Exit;
102. untFixForm.FixForm(Self);
103. end;