lock_about.pas
上传用户:zhkydz
上传日期:2013-04-26
资源大小:44k
文件大小:5k
- {
- 通用关于界面 版权所有 2001
- -'`"_ -'`"
- / / "
- / /\__ / ___ 西安科技学院143信箱 710054
- | | -"`.-( |
- | | | | " | | 万 重
- | / / "-" |
- ___/ / (o o) (__/ 电邮: mantousoft@sina.com
- __| _ _ |__
- ( ( ) ) 网址: http://mantousoft.51.net
- _.-.___.-./_/
- __ | | __ QQ : 6036742
- | .| |./ |
- | '#. .#' |
- |__/ '"" __| 2001.3.1
- -/ -
- }
- unit lock_about;
- interface
- uses
- Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
- ExtCtrls, Buttons, StdCtrls, ShellAPI, TFlatButtonUnit;
- type
- Tfrm_about = class(TForm)
- ProductName: TLabel;
- ProgramIcon: TImage;
- Copyright: TLabel;
- Version: TLabel;
- lblOs: TLabel;
- lblMemory: TLabel;
- lb_email: TLabel;
- lb_HomePage: TLabel;
- homepage: TLabel;
- email: TLabel;
- FlatButton1: TFlatButton;
- procedure FormCreate(Sender: TObject);
- procedure emailClick(Sender: TObject);
- procedure homepageClick(Sender: TObject);
- procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- procedure FormPaint(Sender: TObject);
- procedure FormClose(Sender: TObject; var Action: TCloseAction);
- procedure FlatButton1Click(Sender: TObject);
- private
- procedure GetOSInfo;
- procedure GetMemoryInfo ;
- procedure GetBuildInfo;
- { Private declarations }
- public
- { Public declarations }
- end;
- var
- frm_about: Tfrm_about;
- implementation
- {$R *.DFM}
- procedure Tfrm_About.GetBuildInfo;
- var
- V1,V2,V3,V4: Word;
- VerInfoSize: DWORD;
- VerInfo: Pointer;
- VerValueSize: DWORD;
- VerValue: PVSFixedFileInfo;
- Dummy: DWORD;
- begin
- VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
- GetMem(VerInfo, VerInfoSize);
- GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
- VerQueryValue(VerInfo, '', Pointer(VerValue), VerValueSize);
- with VerValue^ do
- begin
- V1 := dwFileVersionMS shr 16;
- V2 := dwFileVersionMS and $FFFF;
- V3 := dwFileVersionLS shr 16;
- V4 := dwFileVersionLS and $FFFF;
- end;
- FreeMem(VerInfo, VerInfoSize);
- Version.Caption:=Version.Caption +'1.62 '+Format('(Build %d%d%d%d)',[v1,v2,v3,v4]);
- end;
- procedure Tfrm_About.GetMemoryInfo ;
- var
- MS: TMemoryStatus;
- begin
- MS.dwLength:=SizeOf(TMemoryStatus);
- GlobalMemoryStatus(MS);
- lblMemory.Caption:=lblMemory.Caption +FormatFloat('#,###" KB"',MS.dwTotalPhys div 1024);
- end;
- procedure Tfrm_About.GetOSInfo;
- var
- Platform: string;
- BuildNumber: Integer;
- begin
- case Win32Platform of
- VER_PLATFORM_WIN32_WINDOWS:
- begin
- Platform := 'Windows 95';
- BuildNumber := Win32BuildNumber and $0000FFFF;
- end;
- VER_PLATFORM_WIN32_NT:
- begin
- Platform := 'Windows NT';
- BuildNumber := Win32BuildNumber;
- end;
- else
- begin
- Platform := 'Windows';
- BuildNumber := 0;
- end;
- end;
- if(Win32Platform = VER_PLATFORM_WIN32_WINDOWS)
- or(Win32Platform = VER_PLATFORM_WIN32_NT) then
- begin
- if Win32CSDVersion = ''
- then lblOS.Caption := lblOS.Caption+Format('%s %d.%d (Build %d)',[Platform,Win32MajorVersion,Win32MinorVersion,BuildNumber])
- else lblOS.Caption := lblOS.Caption+Format('%s %d.%d (Build %d: %s)',[Platform,Win32MajorVersion,Win32MinorVersion, BuildNumber,Win32CSDVersion]);
- end else lblOS.Caption := lblOS.Caption+Format('%s %d.%d', [Platform,Win32MajorVersion,Win32MinorVersion])
- end;
- procedure Tfrm_about.FormCreate(Sender: TObject);
- var
- R : HRgn;
- begin
- R :=CreateRoundRectRgn(0,0,Width,Height,5,5);
- SetWindowRgn(Handle,R,True);
- {begin about infomation}
- try
- Caption:='关于['+application.Title+']'; //title
- ProgramIcon.Picture.icon:=Application.Icon; //icon
- ProductName.Caption:=ProductName.Caption+Application.Title;//name
- GetBuildInfo; //version
- Copyright.Caption:=Copyright.Caption+'中国-西安-孜孜软件';
- GetMemoryInfo;
- GetOsinfo;
- except
- MessageBox(handle,'某些信息不能取得','提示',MB_OK);
- end;
- {end about infomation}
- end;
- procedure Tfrm_about.emailClick(Sender: TObject);
- begin
- ShellExecute(Self.Handle,'Open',PChar('mailto:mantousoft@sina.com?Subject=关于EXE文件加密器'),nil,nil,1);
- // ShellExecute(Self.Handle,'Open',PChar('http://mantousoft.51.net/myemail/myemail.php'),nil,nil, 1);
- end;
- procedure Tfrm_about.homepageClick(Sender: TObject);
- begin
- ShellExecute(Self.Handle,'Open',PChar('http://mantousoft.51.net'),nil,nil,1);
- end;
- procedure Tfrm_about.FormMouseDown(Sender: TObject; Button: TMouseButton;
- Shift: TShiftState; X, Y: Integer);
- begin
- ReleaseCapture;
- SendMessage(Handle, WM_SYSCOMMAND, $F012, 0);
- end;
- procedure Tfrm_about.FormPaint(Sender: TObject);
- begin
- {begin draw}
- Canvas.Pen.Color:=$00555E66;
- Canvas.Pen.Width:=10;
- Canvas.RoundRect(0,0,Width,Height,5,5);
- Canvas.Pen.Color:=$00996633;
- Canvas.Pen.Width:=2;
- Canvas.PenPos:=Point(15,110);
- Canvas.LineTo(Width-15,110);
- {draw over}
- end;
- procedure Tfrm_about.FormClose(Sender: TObject; var Action: TCloseAction);
- begin
- Action:=caFree;
- end;
- procedure Tfrm_about.FlatButton1Click(Sender: TObject);
- begin
- Close;
- end;
- end.