форум вебмастероff на AlfaSpace.NET

procedure Register; 

implementation 
uses dialogs; 
procedure Register; 
begin 
RegisterComponents('GSPackage', [TgsFileVersionInfo]); 
end; 

{ TgsFileVersionInfo } 
     
    procedure TgsFileVersionInfo.ClearAll; 
    begin 
    FVersionInfoSize: -1; 
    FCompanyName := ''; 
    FFileDescription := ''; 
    FFileVersion := ''; 
    FInternalName := ''; 
    FLegalCopyright := ''; 
    FOriginalFilename := ''; 
    FProductName := ''; 
    FProductVersion := ''; 
    FComments := ''; 
    end; 
     
    function TgsFileVersionInfo.GetBuildOnly: string; 
    var p: integer; 
    s: string; 
    begin 
    s := FileVersion; 
    p := LastDelimiter('.',s); 
    Result := copy(s,p+1,length(s)-p); 
    end; 
     
    procedure TgsFileVersionInfo.LoadFromFile; 
    var VISize:   cardinal; 
    VIBuff:   pointer; 
    trans:    pointer; 
    buffsize: cardinal; 
    temp: integer; 
    str: pchar; 
    LangCharSet: string; 
     
    function GetStringValue(const From: string): string; 
    begin 
    VerQueryValue(VIBuff,pchar('\StringFileInfo\'+LanguageInfo+'\'+From), pointe 
r(str), 
    buffsize); 
    if buffsize > 0 then Result := str else Result := 'n/a'; 
    end; 
     
    begin 
    ClearAll; 
    VIBuff := nil; 
    if not fileexists(Filename) then raise EFilerError.Create('File not found: ' 
+Filename); 
    VISize := GetFileVersionInfoSize(pchar(Filename),buffsize); 
    FVersionInfoSize := VISize; 
    if VISize < 1 then raise EReadError.Create('Invalid version info record in f 
ile '+Filename); 
    VIBuff := AllocMem(VISize); 
    GetFileVersionInfo(pchar(Filename),cardinal(0),VISize,VIBuff); 
     
    VerQueryValue(VIBuff,'\VarFileInfo\Translation',Trans,buffsize); 
    if buffsize >= 4 then 
    begin 
    temp:=0; 
    StrLCopy(@temp, pchar(Trans), 2); 
    LangCharSet:=IntToHex(temp, 4); 
    StrLCopy(@temp, pchar(Trans)+2, 2); 
    FLanguageInfo := LangCharSet+IntToHex(temp, 4); 
    end else raise EReadError.Create('Invalid language info in file '+Filename); 
     
    FCompanyName := GetStringValue('CompanyName'); 
    FFileDescription := GetStringValue('FileDescription'); 
    FFileVersion := GetStringValue('FileVersion'); 
    FInternalName := GetStringValue('InternalName'); 
    FLegalCopyright := GetStringValue('LegalCopyright'); 
    FOriginalFilename := GetStringValue('OriginalFilename'); 
    FProductName := GetStringValue('ProductName'); 
    FProductVersion := GetStringValue('ProductVersion'); 
    FComments := GetStringValue('Comments'); 
     
    FreeMem(VIBuff,VISize); 
    end; 
     
    procedure TgsFileVersionInfo.SetFilename(const Value: TFilename); 
    begin 
    FFilename := Value; 
    LoadFromFile; 
    end; 
     
    end.