home *** CD-ROM | disk | FTP | other *** search
/ Chip 2001 December / Chip_2001-12_cd1.bin / zkuste / delphi / kolekce / d56 / DM2KVCL.ZIP / ABOUT.PAS next >
Pascal/Delphi Source File  |  2000-09-27  |  6KB  |  145 lines
  1. {****************************************************************************}
  2. {                            Data Master 2000                                }
  3. {****************************************************************************}
  4. unit About;
  5. {$B-,X+,S+}
  6. interface
  7.  
  8. uses Common, Windows, ShellAPI, MMSystem, SysUtils;
  9.  
  10. type
  11.   TVersionStringKey=(vskComments, vskProductName, vskProductVersion,
  12.   vskFileDescription, vskFileVersion, vskInternalName, vskOriginalFilename,
  13.   vskLegalCopyright, vskLegalTrademarks, vskCompanyName);
  14.  
  15. const
  16.   VersionStringKeys: array[TVersionStringKey] of string=
  17.    ('Comments', 'ProductName', 'ProductVersion',
  18.    'FileDescription', 'FileVersion', 'InternalName', 'OriginalFilename',
  19.    'LegalCopyright', 'LegalTrademarks', 'CompanyName');
  20.  
  21.   cSystemRes=0;
  22.   cGDIRes=1;
  23.   cUSERRes=2;
  24.  
  25.  
  26. function GetVersionString(Key,FName: string): string;
  27. {This function allows to retrieve version information from resource}
  28. function GetFreeMemory: string;                {returns free memory in kbytes}
  29. function GetTotalMemory: string; {returns available physical memory in kbytes}
  30. procedure ShellAboutBox(Title, FName: string; H,Ico: THandle; Snd: boolean);
  31. {This function displays standard shell about box, e.g.
  32. with Application do ShellAboutBox(Title,Exename,Handle,Icon.Handle,true);}
  33. procedure ShellOpenFile(Name: string);          {may run browser or mailer...}
  34. function GetFreeSystemResources(N: word): word;     {thunked from 16-bit USER}
  35. {This function allows to determine system resources like in Win16}
  36. function IsPreRelease: boolean;    {true if current file build is pre-release}
  37.  
  38. implementation
  39.  
  40. function IsPreRelease: boolean;
  41. var H: THandle; VBS,I: dword; VB,Root: pointer; FN: array[0..300] of char;
  42. begin
  43.   GetModuleFileName(HInstance,FN,SizeOf(FN)-1);
  44.   VBS:=GetFileVersionInfoSize(FN, H);
  45.   GetMem(VB,VBS); Result:=false;
  46.   try
  47.     if GetFileVersionInfo(FN,H,VBS,VB) then
  48.        if VerQueryValue(VB,'\',Root,I) then
  49.           if (VS_FIXEDFILEINFO(Root^).dwFileFlags and VS_FF_PRERELEASE)<>0
  50.           then Result:=true;
  51.   finally
  52.     FreeMem(VB,VBS);
  53.   end;
  54. end;
  55.  
  56. function GetVersionString(Key,FName: string): string;
  57. var FN,K: array[0..255] of char; VerBuf: PChar;
  58.     Han: THandle; VerBufLen, ValBufLen: cardinal;
  59.     ValBuf: pointer; LangCharID: longint;
  60. begin
  61.   Result:=''; StrPCopy(FN,FName);                                  {make name}
  62.   VerBufLen:=GetFileVersionInfoSize(FN, Han);        {get version buffer size}
  63.   GetMem(VerBuf, VerBufLen);                         {alloc memory for buffer}
  64.   try
  65.     if not GetFileVersionInfo(FN,Han,VerBufLen,VerBuf) then Exit;   {failure!}
  66.     if VerQueryValue(VerBuf,'\VarFileInfo\Translation',ValBuf,ValBufLen)
  67.        and (ValBufLen>0)                    {determine language & charset IDs}
  68.     then LangCharID:=longint(ValBuf^) else Exit;       {no translation table!}
  69.     StrLFmt(K,sizeof(K),'\StringFileInfo\%4.4x%4.4x\%s',       {make key info}
  70.     [(LangCharID and $ffff),(LangCharID shr 16),Key]);    {according to ID!!!}
  71.     if VerQueryValue(VerBuf,K,ValBuf,ValBufLen) then
  72.     begin StrMove(FN,PChar(ValBuf),ValBufLen); Result:=StrPas(FN); end;
  73.   finally
  74.     FreeMem(VerBuf, VerBufLen);                          {free version buffer}
  75.   end;
  76. end;
  77.  
  78. {$ifdef WIN32}
  79. function LoadLibrary16(LibraryName: PChar): THandle;
  80. stdcall; external kernel32 index 35;
  81. procedure FreeLibrary16(HInstance: THandle);
  82. stdcall; external kernel32 index 36;
  83. function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer;
  84. stdcall; external kernel32 index 37;
  85. procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk';
  86.  
  87. var hInst16: THandle; GFSR: Pointer;
  88. function GetFreeSystemResources(N: word): word;     {thunked from 16-bit USER}
  89. var ThunkTrash: array[0..$20] of Word;
  90. begin                  {implementation taken from Lischner's FreeRes.pas unit}
  91.   ThunkTrash[0]:=hInst16;
  92.   hInst16:=LoadLibrary16('user.exe');
  93.   if hInst16>=32 then
  94.   begin
  95.     FreeLibrary16(hInst16);
  96.     GFSR:=GetProcAddress16(hInst16, 'GetFreeSystemResources');
  97.     if GFSR<>nil then
  98.     asm
  99.       push N            { push arguments }
  100.       mov edx, GFSR     { load 16-bit procedure pointer }
  101.       call QT_Thunk     { call thunk }
  102.       mov Result, ax    { save the result }
  103.     end;
  104.   end;
  105. end;
  106. {$endif}
  107.  
  108. function GetFreeMemory: string;
  109. {$ifdef WIN32} var MemStat: TMemoryStatus; {$endif}
  110. begin
  111. {$ifdef WIN32}
  112.   MemStat.dwLength:=SizeOf(TMemoryStatus); GlobalMemoryStatus(MemStat);
  113.   Result:=IntToStr(MemStat.dwAvailPhys DIV 1024)+'k';
  114. {$else}
  115.   Result:=IntToStr(GetFreeSpace(0) DIV 1024)+'k';
  116. {$endif}
  117. end;
  118.  
  119. function GetTotalMemory: string;
  120. var MemStat: TMemoryStatus;
  121. begin
  122.   MemStat.dwLength:=SizeOf(TMemoryStatus); GlobalMemoryStatus(MemStat);
  123.   Result:=IntToStr(MemStat.dwTotalPhys DIV 1024)+'k';
  124. end;
  125.  
  126. procedure ShellAboutBox(Title, FName: string; H,Ico: THandle; Snd: boolean);
  127. var B,Bb: array[0..1000] of char;
  128. begin
  129.   StrPLCopy(B, Title, SizeOf(B)-1);
  130.   StrPLCopy(Bb, 'Build '+
  131.     GetVersionString(VersionStringKeys[vskFileVersion],FName)+CRLF+
  132.     GetVersionString(VersionStringKeys[vskComments],FName),SizeOf(Bb)-1);
  133.   if Snd then PlaySound('systemstart',0,SND_ALIAS+SND_ASYNC);
  134.   ShellAbout(H, B, Bb, Ico);
  135. end;
  136.  
  137. procedure ShellOpenFile(Name: string);
  138. var B: array[0..1000] of char;
  139. begin
  140.   StrPLCopy(B,Name,SizeOf(B)-1);
  141.   ShellExecute(0,nil{'open'?},B,nil,nil,SW_NORMAL);
  142. end;
  143.  
  144. end.
  145.