Delphi 通用程序全屏设计

开发环境 Delphi XE 10.1 Berlin, Delphi 2007.

1. 窗体模板

unit ufrmBase;

interface

Uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
  Vcl.Graphics, Vcl.Controls, Vcl.Dialogs, Vcl.Forms, System.Math, System.TypInfo;

Const
  //记录设计时的屏幕分辨率
  OriWidth  = 1024;
  OriHeight = 768;

  VtlWidth  = 800;
  VtlHeight = 1280;

Type
  TfrmBase=Class(TForm)
    procedure FormShow(Sender: TObject);
  Private
    fScrResolutionRateW: Double;
    fScrResolutionRateH: Double;
    fIsFitDeviceDone: Boolean;
    procedure FitDeviceResolution(AScreenNo:Byte = 1);
  Protected
    FExecResult : Boolean;
    Property IsFitDeviceDone:Boolean Read fIsFitDeviceDone;
    Property ScrResolutionRateH:Double Read fScrResolutionRateH;
    Property ScrResolutionRateW:Double Read fScrResolutionRateW;
  Public
    FScrNo : Byte;
    FResolution: Byte;
    property ExecResult:Boolean read FExecResult ;
    Constructor Create(AOwner: TComponent); Override;
  End;

implementation

{$R *.dfm}

constructor TfrmBase.Create(AOwner: TComponent);
begin
  Inherited Create(AOwner);
  doubleBuffered := True;
  FExecResult := False;
  FScrNo := 0;
  FResolution:= 0;
end;

procedure TfrmBase.FitDeviceResolution(AScreenNo:Byte);
Var
  LocList:TList;
  LocFontRate:Double;
  LocFontSize:Integer;
  LocFont:TFont;
  locK:Integer;
  bNeed : Boolean;

  //计算尺度调整的基本参数
  Procedure CalBasicScalePars(AScreenNo:Byte);
  var
    AMonitor : TMonitor;
    bHaveMonitor : Boolean;   //是否存在副屏
    iScreen : Integer;
  Begin
    try
      if not (AScreenNo in [0,1]) then Exit;
      if (screen.MonitorCount <= 0) or (screen.MonitorCount > 2)  then Exit;
      bHaveMonitor := screen.MonitorCount >= 2;
      if (AScreenNo = 0) then
      begin
        for iScreen := 0 to screen.MonitorCount - 1 do
        begin
          if Screen.Monitors[iScreen].Primary = True then
          begin
            AMonitor := screen.Monitors[iScreen];
            Break;
          end;
        end;
        if AMonitor = nil then Exit;
        fScrResolutionRateH:=AMonitor.height/OriHeight;
        fScrResolutionRateW:=AMonitor.Width/OriWidth;
      end
      else
      begin
        if not bHaveMonitor then
        begin
          fScrResolutionRateH := 1.0;
          fScrResolutionRateW := 1.0;
        end
        else
        begin
          for iScreen := 0 to screen.MonitorCount - 1 do
          begin
            if Screen.Monitors[iScreen].Primary = False then
            begin
              AMonitor := screen.Monitors[iScreen];
              Break;
            end;
          end;
          if AMonitor = nil then Exit;
          if FResolution = 0 then         //副屏横屏
          begin
            fScrResolutionRateH:=AMonitor.height/OriHeight;
            fScrResolutionRateW:=AMonitor.Width/OriWidth;
          end
          else                                                 //副屏竖屏
          begin
            fScrResolutionRateH:=AMonitor.height/VtlHeight;
            fScrResolutionRateW:=AMonitor.Width/VtlWidth;
          end;
        end;
      end;
      LocFontRate:=Min(fScrResolutionRateH,fScrResolutionRateW);
    except
      Raise;
    end;
  End;

  function PropertyExists(const AObject: TObject;const APropName:String):Boolean;
  //判断一个属性是否存在
  var
   PropInfo:PPropInfo;
  begin
   PropInfo:=GetPropInfo(AObject.ClassInfo,APropName);
   Result:=Assigned(PropInfo);
  end;

  function 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;

  //保存原有坐标位置：利用递归法遍历各级容器里的控件，直到最后一级
  Procedure ControlsPostoList(vCtl:TControl;vList:TList);
  Var
    locPRect:^TRect;
    i:Integer;
    locCtl:TControl;
    locFontp:^Integer;
  Begin
    try
      New(locPRect);
      locPRect^:=vCtl.BoundsRect;
      vList.Add(locPRect);
      If PropertyExists(vCtl,'FONT') Then
      Begin
        LocFont:=TFont(GetObjectProperty(vCtl,'FONT'));
        New(locFontp);
        locFontP^:=LocFont.Size;
        vList.Add(locFontP);
      End;
      If vCtl Is TWinControl Then
        For i:=0 to TWinControl(vCtl).ControlCount-1 Do
        begin
          locCtl:=TWinControl(vCtl).Controls[i];
          ControlsPosToList(locCtl,vList);
        end;
    except
      Raise;
    end;
  End;

  //计算新的坐标位置：利用递归法遍历各级容器里的控件，直到最后一层。
  // 计算坐标时先计算顶级容器级的，然后逐级递进
  Procedure 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;
      If PropertyExists(vCtl,'FONT') Then
      Begin
        Inc(vK);
        LocFont:=TFont(GetObjectProperty(vCtl,'FONT'));
        locFontSize:=Integer(vList.Items[vK]^);
        LocFont.Size := Round(LocFontRate*locFontSize);
      End;
      Inc(vK);
      If vCtl Is TWinControl Then
        For i:=0 to TwinControl(vCtl).ControlCount-1 Do
        begin
          locCtl:=TWinControl(vCtl).Controls[i];
          AdjustControlsScale(locCtl,vList,vK);
        end;
    except
      Raise;
    end;
  End;

  //释放坐标位置指针和列表对象
  Procedure FreeListItem(vList:TList);
  Var
    i:Integer;
  Begin
    For i:=0 to vList.Count-1 Do
      Dispose(vList.Items[i]);
    vList.Free;
  End;

begin
  LocList:=TList.Create;
  Try
    Try
      CalBasicScalePars(FScrNo);
      ControlsPostoList(Self,locList);
      locK:=0;
      AdjustControlsScale(Self,locList,locK);
    Except on E:Exception Do
      Raise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);
    End;
  Finally
    FreeListItem(locList);
  End;
end;


procedure TfrmBase.FormShow(Sender: TObject);
begin
  fScrResolutionRateH:=1;
  fScrResolutionRateW:=1;
  Try
    if Not fIsFitDeviceDone then
    Begin
      FitDeviceResolution(FScrNo);
      fIsFitDeviceDone:=True;
    End;
  Except
    fIsFitDeviceDone:=False;
  End;
end;

end.

2. 主窗体uMainForm(主屏显示)

unit uMainForm;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uFrmBase, Vcl.ExtCtrls, Vcl.StdCtrls, Vcl.Imaging.GIFImg;

type
  TMainForm = class(TFrmBase)
    pnl_Main: TPanel;
    Button1: TButton;
    Image1: TImage;
    procedure FormShow(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    //覆盖任务栏
    procedure SetFormMonitor(Form: TCustomForm; MonitorIndex: integer);
  end;

var
  MainForm: TMainForm;

implementation

{$R *.dfm}

procedure TMainForm.Button1Click(Sender: TObject);
begin
  inherited;
  Application.Terminate;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  inherited;
  DoubleBuffered:= True;
  Image1.Picture.LoadFromFile('loading.gif');
  TGIFImage(Image1.Picture.Graphic).AnimationSpeed:= 300;
  TGIFImage(Image1.Picture.Graphic).Animate:= true;
end;

procedure TMainForm.FormShow(Sender: TObject);
begin
  FScrNo:= 0;
  inherited;
  SetFormMonitor(TCustomForm(Self), FScrNo);
end;

procedure TMainForm.SetFormMonitor(Form: TCustomForm; MonitorIndex: integer);
var
  iL, iT, iW, iH: Integer;
begin
  if (MonitorIndex > -1) and (MonitorIndex < Screen.MonitorCount) then
  begin
    iL := Screen.Monitors[MonitorIndex].Left + ((Screen.Monitors[MonitorIndex].Width - Form.Width) div 2);
    iT := Screen.Monitors[MonitorIndex].Top + ((Screen.Monitors[MonitorIndex].Height - Form.Height) div 2);
    iW := Form.Width;
    iH := Form.Height;

    Form.SetBounds(iL, iT, iW, iH);
    Form.MakeFullyVisible(screen.Monitors[MonitorIndex]);
  end;
end;

end.

3. 次窗体uMonitorForm_H(副屏横向显示)

unit uMonitorForm_H;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uFrmBase, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TMonitorForm_H = class(TFrmBase)
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MonitorForm_H: TMonitorForm_H;

implementation

{$R *.dfm}

procedure TMonitorForm_H.FormShow(Sender: TObject);
begin
  FScrNo:= 1;
  FResolution:= 0;
  inherited;
end;

end.

4. 次窗体uMonitorForm_V(副屏竖向显示)

unit uMonitorForm_V;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uFrmBase, Vcl.StdCtrls, Vcl.ExtCtrls;

type
  TMonitorForm_V = class(TFrmBase)
    pnl_Main: TPanel;
    Label1: TLabel;
    Panel1: TPanel;
    Panel2: TPanel;
    Memo1: TMemo;
    procedure FormShow(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  MonitorForm_V: TMonitorForm_V;

implementation

{$R *.dfm}

procedure TMonitorForm_V.FormShow(Sender: TObject);
begin
  FScrNo:= 1;
  FResolution:= 1;
  inherited;
end;

end.

5. 欢迎界面窗体uFrmWelcome

unit uFrmWelcome;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.Imaging.GIFImg;

type
  TfrmWelcome = class(TForm)
    lblInfo: TLabel;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    function GetInfo: string;
    procedure SetInfo(const Value: string);
  public
    { Public declarations }
    property Info : string read GetInfo write SetInfo;
  end;

var
  frmWelcome: TfrmWelcome;

implementation

{$R *.dfm}

{ TfrmWelcome }

procedure TfrmWelcome.FormCreate(Sender: TObject);
begin
  DoubleBuffered:= True;
end;

function TfrmWelcome.GetInfo: string;
begin
  Result := lblInfo.Caption;
end;

procedure TfrmWelcome.SetInfo(const Value: string);
begin
  lblInfo.Caption := Value;
end;

end.

6. uFactory单元  全局控制

unit uFactory;

interface

uses System.SysUtils, Vcl.Forms;

type
  TFactory= class
  private
    Finfo: string;
    FIsHaveMonitors: Boolean;       //是否拥有副屏
    FMonitorModel: Byte;            //0 横向 1 竖向
    procedure SetInfo(const value: string);
  protected
    property Info: string read Finfo write SetInfo;

    function CreateMainForm : boolean; virtual;
    function CreateMonitorForm : boolean; virtual;

    function ShowWelcome : boolean; virtual;
    function HideWelcome : Boolean; virtual;

    procedure SetScreen ;     //设置主窗体和用户窗体的分屏显示
  public
    constructor Create; virtual;
    destructor Destroy; override;

    function Factory : Boolean; virtual;
  end;

implementation

uses uMainForm, uMonitorForm_V, uMonitorForm_H, uFrmWelcome;

{ TFactory }

constructor TFactory.Create;
begin
  FIsHaveMonitors:= (Screen.MonitorCount= 2);
  FMonitorModel:= 1;
  frmWelcome := TfrmWelcome.Create(nil);
  frmWelcome.Show;
end;

function TFactory.CreateMainForm: boolean;
begin
  Result:= false;
  Application.CreateForm(TMainForm, MainForm);
  Result:= True;
end;

function TFactory.CreateMonitorForm: boolean;
begin
  Result:= false;
  if FMonitorModel= 0 then
    Application.CreateForm(TMonitorForm_H, MonitorForm_H)
  else
    Application.CreateForm(TMonitorForm_V, MonitorForm_V);
  Result:= True;
end;

destructor TFactory.Destroy;
begin
  if Assigned(MainForm) then
    FreeAndNil(MainForm);
  if Assigned(MonitorForm_H) then
    FreeAndNil(MonitorForm_H);
  if Assigned(MonitorForm_V) then
    FreeAndNil(MonitorForm_V);
  if Assigned(frmWelcome) then
    FreeAndNil(frmWelcome);
  inherited;
end;

function TFactory.Factory: Boolean;
begin
  Result:= False;
  if not ShowWelcome then Exit;
  frmWelcome.Update;
  info:= '系统初始化...';
  Sleep(1000);
  info:= '创建副屏显示...';
  Sleep(1000);
  if not CreateMonitorForm then Exit;
  info:= '创建主屏显示...';
  Sleep(1000);
  if not CreateMainForm then Exit;
  Sleep(1000);
  if not HideWelcome then Exit;
  SetScreen;
  Result:= True;
end;

function TFactory.HideWelcome: Boolean;
begin
  frmWelcome.Hide;
  Result := True;
end;

procedure TFactory.SetInfo(const value: string);
begin
  Finfo:= value;
  frmWelcome.Info := Info;
  frmWelcome.Update;
end;

procedure TFactory.SetScreen;
var
  MonitorCount, iloop, iScreen: Integer;
begin
  MonitorCount:= Screen.MonitorCount;
  if MonitorCount= 1 then
  begin
    if Assigned(MainForm) then
    begin
      MainForm.Left:= MainForm.Left+ Screen.Monitors[0].Left;
      MainForm.Top:= MainForm.Top+ Screen.Monitors[0].Top;
      MainForm.Show;
      MainForm.MakeFullyVisible(Screen.Monitors[0]);
    end;
  end
  else
  begin
    for iloop := MonitorCount downto 1 do
    begin
      iScreen:= iloop- 1;
      if Screen.Monitors[iScreen].Primary= True then
      begin
        if Assigned(MainForm) then
        begin
          MainForm.Left:= MainForm.Left+ Screen.Monitors[iScreen].Left;
          MainForm.Top:= MainForm.Top+ Screen.Monitors[iScreen].Top;
          MainForm.Show;
          MainForm.MakeFullyVisible(Screen.Monitors[iScreen]);
        end;
      end
      else
      begin
        case FMonitorModel of
          0: begin
            if Assigned(MonitorForm_H) then
            begin
              MonitorForm_H.Left:= MonitorForm_H.Left+ Screen.Monitors[iScreen].Left;
              MonitorForm_H.Top := MonitorForm_H.Top+ Screen.Monitors[iScreen].Top;
              MonitorForm_H.Show;
              MonitorForm_H.MakeFullyVisible(Screen.Monitors[iScreen]);
            end;
          end;
          1: begin
            if Assigned(MonitorForm_V) then
            begin
              MonitorForm_V.Left:= MonitorForm_V.Left+ Screen.Monitors[iScreen].Left;
              MonitorForm_V.Top := MonitorForm_V.Top+ Screen.Monitors[iScreen].Top;
              MonitorForm_V.Show;
              MonitorForm_V.MakeFullyVisible(Screen.Monitors[iScreen]);
            end;
          end;
        else
          //
        end;
      end;
    end;
  end;
end;

function TFactory.ShowWelcome: boolean;
begin
  frmWelcome.Info := '正在启动';
  Result := true;
end;

end.

7. 工程文件

program DelphiFullScreen;

uses
  Winapi.Windows,
  System.SysUtils,
  Vcl.Forms,
  uFrmBase in 'uFrmBase.pas' {FrmBase},
  uMainForm in 'uMainForm.pas' {MainForm},
  uMonitorForm_V in 'uMonitorForm_V.pas' {MonitorForm_V},
  uMonitorForm_H in 'uMonitorForm_H.pas' {MonitorForm_H},
  uFactory in 'uFactory.pas',
  uFrmWelcome in 'uFrmWelcome.pas' {frmWelcome};

{$R *.res}

const
  appBj= 'Exception';
  MB_MINE = MB_OK or MB_ICONINFORMATION or MB_TASKMODAL;

var
  factory: TFactory;
  hMutex: DWORD;

begin
  hMutex := CreateMutex(nil, TRUE, PChar(appBj));
  if (GetLastError = ERROR_ALREADY_EXISTS) then
  begin
    Application.MessageBox(PChar('程序运行中，请不要重复启动程序！'),
      PChar('提示'), MB_OK + MB_ICONWARNING + MB_TOPMOST);
    ReleaseMutex(hMutex);
    Exit;
  end
  else if hMutex = ERROR_INVALID_HANDLE then
  begin
    MessageBox(0, '对象被占用，无法启动程序！', '信息',MB_MINE);
    ReleaseMutex(hMutex);
    Exit;
  end
  else
  begin
    Application.Initialize;
    try
      factory:= TFactory.Create;
      try
        if not factory.Factory then Exit;
        Application.Run;
      finally
        ReleaseMutex(hMutex);
        FreeAndNil(factory);
      end;
    except
      raise;
    end;
  end;
end.

8. 注意

 

结束!