dialog_about.pas
上传用户:zhkydz
上传日期:2013-04-26
资源大小:44k
文件大小:5k
源码类别:

破解

开发平台:

Asm

  1. {
  2.           通用关于界面 版权所有 2001
  3.       -'`"_         -'`" 
  4.      /            /      "
  5.     /     /\__   /  ___          西安科技学院143信箱 710054
  6.    |      |   -"`.-(      |
  7.    |      |  |     | "  |  |                万  重
  8.    |     /  /  "-"        |
  9.     ___/  /  (o o)    (__/       电邮: mantousoft@sina.com
  10.          __| _     _ |__
  11.         (      ( )      )          网址: http://mantousoft.51.net
  12.          _.-.___.-./_/
  13.            __  | |  __             QQ  : 6036742
  14.           |  .| |./  |
  15.           | '#.   .#' |
  16.           |__/ '"" __|                     2001.3.1
  17.         -/             -
  18. }
  19. unit dialog_about;
  20. interface
  21. uses
  22.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  23.   ExtCtrls, Buttons, StdCtrls, ShellAPI, TFlatButtonUnit;
  24. type
  25.   Tfrm_about = class(TForm)
  26.     ProductName: TLabel;
  27.     ProgramIcon: TImage;
  28.     Copyright: TLabel;
  29.     Version: TLabel;
  30.     lblOs: TLabel;
  31.     lblMemory: TLabel;
  32.     lb_email: TLabel;
  33.     lb_HomePage: TLabel;
  34.     homepage: TLabel;
  35.     email: TLabel;
  36.     FlatButton1: TFlatButton;
  37.     procedure FormCreate(Sender: TObject);
  38.     procedure emailClick(Sender: TObject);
  39.     procedure homepageClick(Sender: TObject);
  40.     procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
  41.       Shift: TShiftState; X, Y: Integer);
  42.     procedure FormPaint(Sender: TObject);
  43.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  44.     procedure FlatButton1Click(Sender: TObject);
  45.   private
  46.     procedure GetOSInfo;
  47.     procedure GetMemoryInfo ;
  48.     procedure GetBuildInfo;
  49.     { Private declarations }
  50.   public
  51.     { Public declarations }
  52.   end;
  53. var
  54.   frm_about: Tfrm_about;
  55. implementation
  56. {$R *.DFM}
  57. procedure Tfrm_About.GetBuildInfo;
  58. var
  59.   V1,V2,V3,V4: Word;
  60.   VerInfoSize: DWORD;
  61.   VerInfo: Pointer;
  62.   VerValueSize: DWORD;
  63.   VerValue: PVSFixedFileInfo;
  64.   Dummy: DWORD;
  65. begin
  66.   VerInfoSize := GetFileVersionInfoSize(PChar(ParamStr(0)), Dummy);
  67.   GetMem(VerInfo, VerInfoSize);
  68.   GetFileVersionInfo(PChar(ParamStr(0)), 0, VerInfoSize, VerInfo);
  69.   VerQueryValue(VerInfo, '', Pointer(VerValue), VerValueSize);
  70.   with VerValue^ do
  71.   begin
  72.     V1 := dwFileVersionMS shr 16;
  73.     V2 := dwFileVersionMS and $FFFF;
  74.     V3 := dwFileVersionLS shr 16;
  75.     V4 := dwFileVersionLS and $FFFF;
  76.   end;
  77.   FreeMem(VerInfo, VerInfoSize);
  78.   Version.Caption:=Version.Caption +'1.21 '+Format('(Build %d%d%d%d)',[v1,v2,v3,v4]);
  79. end;
  80. procedure Tfrm_About.GetMemoryInfo ;
  81. var
  82.   MS: TMemoryStatus;
  83. begin
  84.   MS.dwLength:=SizeOf(TMemoryStatus);
  85.   GlobalMemoryStatus(MS);
  86.   lblMemory.Caption:=lblMemory.Caption +FormatFloat('#,###" KB"',MS.dwTotalPhys div 1024);
  87. end;
  88. procedure Tfrm_About.GetOSInfo;
  89. var
  90.   Platform: string;
  91.   BuildNumber: Integer;
  92. begin
  93.   case Win32Platform of
  94.   VER_PLATFORM_WIN32_WINDOWS:
  95.     begin
  96.       Platform := 'Windows 95';
  97.       BuildNumber := Win32BuildNumber and $0000FFFF;
  98.     end;
  99.   VER_PLATFORM_WIN32_NT:
  100.     begin
  101.       Platform := 'Windows NT';
  102.       BuildNumber := Win32BuildNumber;
  103.     end;
  104.     else
  105.     begin
  106.       Platform := 'Windows';
  107.       BuildNumber := 0;
  108.     end;
  109.   end;
  110.   if(Win32Platform = VER_PLATFORM_WIN32_WINDOWS)
  111.     or(Win32Platform = VER_PLATFORM_WIN32_NT) then
  112.   begin
  113.     if Win32CSDVersion = ''
  114.     then lblOS.Caption := lblOS.Caption+Format('%s %d.%d (Build %d)',[Platform,Win32MajorVersion,Win32MinorVersion,BuildNumber])
  115.     else lblOS.Caption := lblOS.Caption+Format('%s %d.%d (Build %d: %s)',[Platform,Win32MajorVersion,Win32MinorVersion, BuildNumber,Win32CSDVersion]);
  116.   end else lblOS.Caption := lblOS.Caption+Format('%s %d.%d', [Platform,Win32MajorVersion,Win32MinorVersion])
  117. end;
  118. procedure Tfrm_about.FormCreate(Sender: TObject);
  119. var
  120.   R : HRgn;
  121. begin
  122.   R :=CreateRoundRectRgn(0,0,Width,Height,5,5);
  123.   SetWindowRgn(Handle,R,True);
  124.   {begin about infomation}
  125.   try
  126.     Caption:='关于['+application.Title+']';                    //title
  127.     ProgramIcon.Picture.icon:=Application.Icon;                //icon
  128.     ProductName.Caption:=ProductName.Caption+Application.Title;//name
  129.     GetBuildInfo;                                              //version
  130.     Copyright.Caption:=Copyright.Caption+'中国-西安-孜孜软件';
  131.     GetMemoryInfo;
  132.     GetOsinfo;
  133.   except
  134.     MessageBox(handle,'某些信息不能取得','提示',MB_OK);
  135.   end;
  136.   {end about infomation}
  137. end;
  138. procedure Tfrm_about.emailClick(Sender: TObject);
  139. begin
  140.   ShellExecute(Self.Handle,'Open',PChar('mailto:mantousoft@sina.com?Subject=关于EXE文件加密器'),nil,nil,1);
  141. //  ShellExecute(Self.Handle,'Open',PChar('http://mantousoft.51.net/myemail/myemail.php'),nil,nil, 1);
  142. end;
  143. procedure Tfrm_about.homepageClick(Sender: TObject);
  144. begin
  145.   ShellExecute(Self.Handle,'Open',PChar('http://mantousoft.51.net'),nil,nil,1);
  146. end;
  147. procedure Tfrm_about.FormMouseDown(Sender: TObject; Button: TMouseButton;
  148.   Shift: TShiftState; X, Y: Integer);
  149. begin
  150.   ReleaseCapture;
  151.   SendMessage(Handle, WM_SYSCOMMAND, $F012, 0);
  152. end;
  153. procedure Tfrm_about.FormPaint(Sender: TObject);
  154. begin
  155.   {begin draw}
  156.   Canvas.Pen.Color:=$00555E66;
  157.   Canvas.Pen.Width:=10;
  158.   Canvas.RoundRect(0,0,Width,Height,5,5);
  159.   Canvas.Pen.Color:=$00996633;
  160.   Canvas.Pen.Width:=2;
  161.   Canvas.PenPos:=Point(15,110);
  162.   Canvas.LineTo(Width-15,110);
  163.   {draw over}
  164. end;
  165. procedure Tfrm_about.FormClose(Sender: TObject; var Action: TCloseAction);
  166. begin
  167.   Action:=caFree;
  168. end;
  169. procedure Tfrm_about.FlatButton1Click(Sender: TObject);
  170. begin
  171.   Close;
  172. end;
  173. end.