Delphi 通用程序全屏设计

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

1. 窗体模板

unit ufrmBase;interfaceUsesWinapi.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;TypeTfrmBase=Class(TForm)procedure FormShow(Sender: TObject);PrivatefScrResolutionRateW: Double;fScrResolutionRateH: Double;fIsFitDeviceDone: Boolean;procedure FitDeviceResolution(AScreenNo:Byte = 1);ProtectedFExecResult : Boolean;Property IsFitDeviceDone:Boolean Read fIsFitDeviceDone;Property ScrResolutionRateH:Double Read fScrResolutionRateH;Property ScrResolutionRateW:Double Read fScrResolutionRateW;PublicFScrNo : Byte;FResolution: Byte;property ExecResult:Boolean read FExecResult ;Constructor Create(AOwner: TComponent); Override;End;implementation{$R *.dfm}constructor TfrmBase.Create(AOwner: TComponent);
beginInherited Create(AOwner);doubleBuffered := True;FExecResult := False;FScrNo := 0;FResolution:= 0;
end;procedure TfrmBase.FitDeviceResolution(AScreenNo:Byte);
VarLocList:TList;LocFontRate:Double;LocFontSize:Integer;LocFont:TFont;locK:Integer;bNeed : Boolean;//计算尺度调整的基本参数Procedure CalBasicScalePars(AScreenNo:Byte);varAMonitor : TMonitor;bHaveMonitor : Boolean;   //是否存在副屏iScreen : Integer;Begintryif not (AScreenNo in [0,1]) then Exit;if (screen.MonitorCount <= 0) or (screen.MonitorCount > 2)  then Exit;bHaveMonitor := screen.MonitorCount >= 2;if (AScreenNo = 0) thenbeginfor iScreen := 0 to screen.MonitorCount - 1 dobeginif Screen.Monitors[iScreen].Primary = True thenbeginAMonitor := screen.Monitors[iScreen];Break;end;end;if AMonitor = nil then Exit;fScrResolutionRateH:=AMonitor.height/OriHeight;fScrResolutionRateW:=AMonitor.Width/OriWidth;endelsebeginif not bHaveMonitor thenbeginfScrResolutionRateH := 1.0;fScrResolutionRateW := 1.0;endelsebeginfor iScreen := 0 to screen.MonitorCount - 1 dobeginif Screen.Monitors[iScreen].Primary = False thenbeginAMonitor := screen.Monitors[iScreen];Break;end;end;if AMonitor = nil then Exit;if FResolution = 0 then         //副屏横屏beginfScrResolutionRateH:=AMonitor.height/OriHeight;fScrResolutionRateW:=AMonitor.Width/OriWidth;endelse                                                 //副屏竖屏beginfScrResolutionRateH:=AMonitor.height/VtlHeight;fScrResolutionRateW:=AMonitor.Width/VtlWidth;end;end;end;LocFontRate:=Min(fScrResolutionRateH,fScrResolutionRateW);exceptRaise;end;End;function PropertyExists(const AObject: TObject;const APropName:String):Boolean;//判断一个属性是否存在varPropInfo:PPropInfo;beginPropInfo:=GetPropInfo(AObject.ClassInfo,APropName);Result:=Assigned(PropInfo);end;function GetObjectProperty(const AObject   : TObject;const APropName : string):TObject;varPropInfo:PPropInfo;beginResult  :=  nil;PropInfo:=GetPropInfo(AObject.ClassInfo,APropName);if Assigned(PropInfo) and(PropInfo^.PropType^.Kind = tkClass) thenResult  :=  GetObjectProp(AObject,PropInfo);end;//保存原有坐标位置：利用递归法遍历各级容器里的控件，直到最后一级Procedure ControlsPostoList(vCtl:TControl;vList:TList);VarlocPRect:^TRect;i:Integer;locCtl:TControl;locFontp:^Integer;BegintryNew(locPRect);locPRect^:=vCtl.BoundsRect;vList.Add(locPRect);If PropertyExists(vCtl,'FONT') ThenBeginLocFont:=TFont(GetObjectProperty(vCtl,'FONT'));New(locFontp);locFontP^:=LocFont.Size;vList.Add(locFontP);End;If vCtl Is TWinControl ThenFor i:=0 to TWinControl(vCtl).ControlCount-1 DobeginlocCtl:=TWinControl(vCtl).Controls[i];ControlsPosToList(locCtl,vList);end;exceptRaise;end;End;//计算新的坐标位置：利用递归法遍历各级容器里的控件，直到最后一层。// 计算坐标时先计算顶级容器级的，然后逐级递进Procedure AdjustControlsScale(vCtl:TControl;vList:TList;Var vK:Integer);VarlocOriRect,LocNewRect:TRect;i:Integer;locCtl:TControl;BegintryIf vCtl.Align<>alClient ThenBeginlocOriRect:=TRect(vList.Items[vK]^);With locNewRect DobeginLeft:=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') ThenBeginInc(vK);LocFont:=TFont(GetObjectProperty(vCtl,'FONT'));locFontSize:=Integer(vList.Items[vK]^);LocFont.Size := Round(LocFontRate*locFontSize);End;Inc(vK);If vCtl Is TWinControl ThenFor i:=0 to TwinControl(vCtl).ControlCount-1 DobeginlocCtl:=TWinControl(vCtl).Controls[i];AdjustControlsScale(locCtl,vList,vK);end;exceptRaise;end;End;//释放坐标位置指针和列表对象Procedure FreeListItem(vList:TList);Vari:Integer;BeginFor i:=0 to vList.Count-1 DoDispose(vList.Items[i]);vList.Free;End;beginLocList:=TList.Create;TryTryCalBasicScalePars(FScrNo);ControlsPostoList(Self,locList);locK:=0;AdjustControlsScale(Self,locList,locK);Except on E:Exception DoRaise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);End;FinallyFreeListItem(locList);End;
end;procedure TfrmBase.FormShow(Sender: TObject);
beginfScrResolutionRateH:=1;fScrResolutionRateW:=1;Tryif Not fIsFitDeviceDone thenBeginFitDeviceResolution(FScrNo);fIsFitDeviceDone:=True;End;ExceptfIsFitDeviceDone:=False;End;
end;end.

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

unit uMainForm;interfaceusesWinapi.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;typeTMainForm = 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;varMainForm: TMainForm;implementation{$R *.dfm}procedure TMainForm.Button1Click(Sender: TObject);
begininherited;Application.Terminate;
end;procedure TMainForm.FormCreate(Sender: TObject);
begininherited;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);
beginFScrNo:= 0;inherited;SetFormMonitor(TCustomForm(Self), FScrNo);
end;procedure TMainForm.SetFormMonitor(Form: TCustomForm; MonitorIndex: integer);
variL, iT, iW, iH: Integer;
beginif (MonitorIndex > -1) and (MonitorIndex < Screen.MonitorCount) thenbeginiL := 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;interfaceusesWinapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uFrmBase, Vcl.StdCtrls, Vcl.ExtCtrls;typeTMonitorForm_H = class(TFrmBase)procedure FormShow(Sender: TObject);private{ Private declarations }public{ Public declarations }end;varMonitorForm_H: TMonitorForm_H;implementation{$R *.dfm}procedure TMonitorForm_H.FormShow(Sender: TObject);
beginFScrNo:= 1;FResolution:= 0;inherited;
end;end.

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

unit uMonitorForm_V;interfaceusesWinapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uFrmBase, Vcl.StdCtrls, Vcl.ExtCtrls;typeTMonitorForm_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;varMonitorForm_V: TMonitorForm_V;implementation{$R *.dfm}procedure TMonitorForm_V.FormShow(Sender: TObject);
beginFScrNo:= 1;FResolution:= 1;inherited;
end;end.

5. 欢迎界面窗体uFrmWelcome

unit uFrmWelcome;interfaceusesWinapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls, Vcl.Imaging.GIFImg;typeTfrmWelcome = 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;varfrmWelcome: TfrmWelcome;implementation{$R *.dfm}{ TfrmWelcome }procedure TfrmWelcome.FormCreate(Sender: TObject);
beginDoubleBuffered:= True;
end;function TfrmWelcome.GetInfo: string;
beginResult := lblInfo.Caption;
end;procedure TfrmWelcome.SetInfo(const Value: string);
beginlblInfo.Caption := Value;
end;end.

6. uFactory单元全局控制

unit uFactory;interfaceuses System.SysUtils, Vcl.Forms;typeTFactory= classprivateFinfo: string;FIsHaveMonitors: Boolean;       //是否拥有副屏FMonitorModel: Byte;            //0 横向 1 竖向procedure SetInfo(const value: string);protectedproperty Info: string read Finfo write SetInfo;function CreateMainForm : boolean; virtual;function CreateMonitorForm : boolean; virtual;function ShowWelcome : boolean; virtual;function HideWelcome : Boolean; virtual;procedure SetScreen ;     //设置主窗体和用户窗体的分屏显示publicconstructor Create; virtual;destructor Destroy; override;function Factory : Boolean; virtual;end;implementationuses uMainForm, uMonitorForm_V, uMonitorForm_H, uFrmWelcome;{ TFactory }constructor TFactory.Create;
beginFIsHaveMonitors:= (Screen.MonitorCount= 2);FMonitorModel:= 1;frmWelcome := TfrmWelcome.Create(nil);frmWelcome.Show;
end;function TFactory.CreateMainForm: boolean;
beginResult:= false;Application.CreateForm(TMainForm, MainForm);Result:= True;
end;function TFactory.CreateMonitorForm: boolean;
beginResult:= false;if FMonitorModel= 0 thenApplication.CreateForm(TMonitorForm_H, MonitorForm_H)elseApplication.CreateForm(TMonitorForm_V, MonitorForm_V);Result:= True;
end;destructor TFactory.Destroy;
beginif Assigned(MainForm) thenFreeAndNil(MainForm);if Assigned(MonitorForm_H) thenFreeAndNil(MonitorForm_H);if Assigned(MonitorForm_V) thenFreeAndNil(MonitorForm_V);if Assigned(frmWelcome) thenFreeAndNil(frmWelcome);inherited;
end;function TFactory.Factory: Boolean;
beginResult:= 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;
beginfrmWelcome.Hide;Result := True;
end;procedure TFactory.SetInfo(const value: string);
beginFinfo:= value;frmWelcome.Info := Info;frmWelcome.Update;
end;procedure TFactory.SetScreen;
varMonitorCount, iloop, iScreen: Integer;
beginMonitorCount:= Screen.MonitorCount;if MonitorCount= 1 thenbeginif Assigned(MainForm) thenbeginMainForm.Left:= MainForm.Left+ Screen.Monitors[0].Left;MainForm.Top:= MainForm.Top+ Screen.Monitors[0].Top;MainForm.Show;MainForm.MakeFullyVisible(Screen.Monitors[0]);end;endelsebeginfor iloop := MonitorCount downto 1 dobeginiScreen:= iloop- 1;if Screen.Monitors[iScreen].Primary= True thenbeginif Assigned(MainForm) thenbeginMainForm.Left:= MainForm.Left+ Screen.Monitors[iScreen].Left;MainForm.Top:= MainForm.Top+ Screen.Monitors[iScreen].Top;MainForm.Show;MainForm.MakeFullyVisible(Screen.Monitors[iScreen]);end;endelsebegincase FMonitorModel of0: beginif Assigned(MonitorForm_H) thenbeginMonitorForm_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: beginif Assigned(MonitorForm_V) thenbeginMonitorForm_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;
beginfrmWelcome.Info := '正在启动';Result := true;
end;end.

7. 工程文件

program DelphiFullScreen;usesWinapi.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}constappBj= 'Exception';MB_MINE = MB_OK or MB_ICONINFORMATION or MB_TASKMODAL;varfactory: TFactory;hMutex: DWORD;beginhMutex := CreateMutex(nil, TRUE, PChar(appBj));if (GetLastError = ERROR_ALREADY_EXISTS) thenbeginApplication.MessageBox(PChar('程序运行中，请不要重复启动程序！'),PChar('提示'), MB_OK + MB_ICONWARNING + MB_TOPMOST);ReleaseMutex(hMutex);Exit;endelse if hMutex = ERROR_INVALID_HANDLE thenbeginMessageBox(0, '对象被占用，无法启动程序！', '信息',MB_MINE);ReleaseMutex(hMutex);Exit;endelsebeginApplication.Initialize;tryfactory:= TFactory.Create;tryif not factory.Factory then Exit;Application.Run;finallyReleaseMutex(hMutex);FreeAndNil(factory);end;exceptraise;end;end;
end.

8. 注意

结束!

Delphi 通用程序全屏设计相关推荐

微信小程序全屏背景图
微信小程序全屏背景图,解决你在设置过程中出现的多次背景图重复出现的问题 wxml <view class="container" style="height: {{ ...
电脑版微信小程序全屏显示方法，手机横屏方法。
电脑版微信小程序全屏显示方法: 在app.json中加入:"resizable": true 注意要与"pages"同级,网上有许多错误方法! 手机横屏方法: ...
Qt 解决程序全屏运行弹窗引发任务栏显示
文章目录摘要在VM虚拟机器中测试 setWindowFlags() 关键字: Qt. Qt::WindowStayOnTopHint. setWindowFlags. Qt::Window. Qt ...
delphi编程界面全屏代码（多种方法）
delphi编程界面全屏代码(多种方法) (2013-02-17 11:47:40) 转载▼ 标签: it 编程分类: 编程相关 BorderStyle:=bsNone; SetBounds(0, ...
linux qt应用程序全屏,QT在ubuntu下实现界面全屏，侧边栏隐藏，上边栏隐藏【实例】...
最近做一个Qt项目(ubuntu 14.04),需要将界面全屏,全屏之后,ubuntu侧边栏隐藏,上边栏也隐藏,只显示Qt的界面. 那么先介绍几个函数: Qt全屏显示函数:showFullScreen ...
linux qt应用程序全屏,QT中MDI应用程序中更改子窗口大小或是全屏显示子窗口的方法...
1.QT中窗口部件QWidget成员函数showFullScreen();是用于将窗口部件全屏显示. 但是他只对窗口模式的部件有用.子窗口的特征是 Qt::SubWindow,不是独立的窗口.因此对其 ...
微信小程序全屏预览视屏、取消全屏预览
前言 bindfullscreenchange 函数可以监听到视频进入和退出全屏时的事件, 利用次函数,可以实现全屏预览和取消全屏预览的功能. 首先看下bindfullscreenchange回调的参 ...
Delphi下实现全屏快速找图找色
前言最近有好几个朋友都在问我找图找色的问题,奇怪?于是乎写了一个专门用于找图找色的单元文件"BitmapData.pas".在这个单元文件中我实现了从文件中导入位图.屏幕截图.鼠 ...
Delphi下实现全屏快速找图找色二、矩阵遍历
二.矩阵遍历矩阵遍历是一个数据结构方面的问题.假设有一个矩阵Matrix,它共有RowCount行,每行有ColCount列,当利用y表示行数,x表示列数,那么利用Matrix[y,x]就可以访问矩 ...

Delphi 通用程序全屏设计

Delphi 通用程序全屏设计相关推荐

最新文章

热门文章