1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:

Type
  tFileInfoVersion = Record
      Major, Minor, Release, Build: Word;
    End;

  tFileInfoBuild = (
      fibDebug, fibPreRelease, fibPatched, fibPrivateBuild,
      fibInfoInferred, fibSpecialBuild
    );
  tFileInfoBuilds = Set Of tFileInfoBuild;

  tFileInfoType = (
      fitUnknow, fitApplication, fitDynamiclinkLibrary, fitDeviceDriver,
      fitFont, fitVirtualDevice, fitStaticlinkLibrary
    );

  tFileInfoTypeDriver = (
      fitdUnknown, fitdCommunication, fitdPrinter, fitdKeyboard, fitdLanguage,
      fitdDisplay, fitdMouse, fitdNetwork, fitdSystem, fitdInstallable, fitdSound
    );

  tFileInfoTypeFont = (
      fitfUnknown,
      fitfRaster,
      fitfVector,
      fitfTrueType
    );

  tFileInfoSpecificAspect = (
      fisaCompanyName, fisaFileDescription, fisaFileVersion, fisaInternalName,
      fisaLegalCopyright,fisaLegalTradeMark, fisaOriginalFileName,
      fisaPrivateBuild, fisaProductName, fisaProductVersion, fisaSpecialBuild,
      fisaComments
    );
  tFileInfoSpecificAspectContent = Array [tFileInfoSpecificAspect] Of String;

  tFileInfo = Record
      Version: tFileInfoVersion;
      Builds: tFileInfoBuilds;
      SpecificAspect: tFileInfoSpecificAspectContent;
      Case FileType: tFileInfoType of
        fitDeviceDriver: (
            TypeDriver: tFileInfoTypeDriver
          );
        fitFont: (
            TypeFont: tFileInfoTypeFont
          )
    End;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:

Function GetFileInfo (aFilename: String; Var aInfo: tFileInfo): Boolean;
Const
  cBuildValues : Array [tFileInfoBuild] Of Word = (
      VS_FF_DEBUG, VS_FF_PRERELEASE, VS_FF_PATCHED, VS_FF_PRIVATEBUILD,
      VS_FF_INFOINFERRED, VS_FF_SPECIALBUILD
    );

  cSpecificAspectValues : Array [tFileInfoSpecificAspect] Of String = (
      'CompanyName', 'FileDescription', 'FileVersion', 'InternalName',
      'LegalCopyright', 'LegalTrademarks', 'OriginalFilename',
      'PrivateBuild', 'ProductName', 'ProductVersion', 'SpecialBuild',
      'Comments'
    );

  cTypeValues : Array [tFileInfoType] Of Word = (
      VFT_UNKNOWN, VFT_APP, VFT_DLL, VFT_DRV, VFT_FONT, VFT_VXD, VFT_STATIC_LIB
    );

  cTypeDriverValues : Array [tFileInfoTypeDriver] Of Word = (
      VFT2_UNKNOWN, VFT2_DRV_COMM, VFT2_DRV_PRINTER, VFT2_DRV_KEYBOARD,
      VFT2_DRV_LANGUAGE, VFT2_DRV_DISPLAY, VFT2_DRV_MOUSE, VFT2_DRV_NETWORK,
      VFT2_DRV_SYSTEM, VFT2_DRV_INSTALLABLE, VFT2_DRV_SOUND
    );

  cTypeFontValues : Array [tFileInfoTypeFont] Of Word = (
      VFT2_UNKNOWN, VFT2_FONT_RASTER, VFT2_FONT_VECTOR, VFT2_FONT_TRUETYPE
    );
Var
  VersionInfoSize, VersionInfoValueSize, Zero: DWord;
  VersionInfo, VersionInfoValue: Pointer;

  BuildLoop: tFileInfoBuild;
  TypeLoop: tFileInfoType;
  TypeDriverLoop: tFileInfoTypeDriver;
  TypeFontLoop: tFileInfoTypeFont;
  SpecificAspectLoop: tFileInfoSpecificAspect;
  LangId: String;
Begin
  Result := False;

  if FileExists (aFilename) then
    Begin
      VersionInfoSize := GetFileVersionInfoSize (PChar (aFilename), Zero);

      if VersionInfoSize = 0 then
        Exit;

      GetMem (VersionInfo, VersionInfoSize);
      Try
        If GetFileVersionInfo (PChar (aFilename), 0, VersionInfoSize, VersionInfo)
          and (0 <> LongInt (VersionInfoValueSize))
        Then
          Begin

            If VerQueryValue (VersionInfo, '\', VersionInfoValue, VersionInfoValueSize) Then
              with TVSFixedFileInfo (VersionInfoValue^) Do
                Begin
                  { Version }
                  With aInfo.Version do
                    Begin
                      Major := HiWord (dwFileVersionMS);
                      Minor := LoWord (dwFileVersionMS);
                      Release := HiWord (dwFileVersionLS);
                      Build := LoWord (dwFileVersionLS);
                    End;

                  { Builds }
                  aInfo.Builds := [];
                  For BuildLoop := Low (BuildLoop) To High (BuildLoop) Do
                    If (dwFileFlagsMask and dwFileFlags and cBuildValues [BuildLoop]) <> 0 Then
                      Include (aInfo.Builds, BuildLoop);

                  { Type }
                  For TypeLoop := Low (TypeLoop) To High (TypeLoop) Do
                    If cTypeValues [TypeLoop] = dwFileType Then
                      Begin
                        aInfo.FileType := TypeLoop;
                        Break;
                      End;

                  { Sub Types }
                  Case aInfo.FileType of
                      fitDeviceDriver:
                        For TypeDriverLoop := Low (TypeDriverLoop) To High (TypeDriverLoop) Do
                          If cTypeDriverValues [TypeDriverLoop] = dwFileSubtype Then
                            Begin
                              aInfo.TypeDriver := TypeDriverLoop;
                              Break;
                            End;
                      fitFont:
                        For TypeFontLoop := Low (TypeFontLoop) To High (TypeFontLoop) Do
                          If cTypeFontValues [TypeFontLoop] = dwFileSubtype Then
                            Begin
                              aInfo.TypeFont := TypeFontLoop;
                              Break;
                            End;
                    End;
                End;

            { SpecificAspect }
            If VerQueryValue (VersionInfo, '\VarFileInfo\Translation', VersionInfoValue, VersionInfoValueSize) Then
               Begin
                 LangId := IntToHex (LoWord (PLongInt (VersionInfoValue)^), 4)
                   + IntToHex (HiWord (PLongInt (VersionInfoValue)^), 4);

                 For SpecificAspectLoop := Low (SpecificAspectLoop) To High (SpecificAspectLoop) Do
                   If VerQueryValue (
                       VersionInfo,
                       PChar (
                           '\StringFileInfo\' + LangId + '\'
                           + cSpecificAspectValues [SpecificAspectLoop]
                         ),
                       VersionInfoValue,
                       VersionInfoValueSize
                     )
                   Then
                     aInfo.SpecificAspect [SpecificAspectLoop] := pChar (VersionInfoValue);
               End;


            Result := True;
          End;
      Finally
        FreeMem (VersionInfo);
      End;
    End;
End;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:

procedure TForm1.Button1Click(Sender: TObject);
var
  FileInfo: tFileInfo;
  Loop: tFileInfoSpecificAspect;
Begin
  // Datei auswählen
  If OpenDialog1.Execute Then
    With Memo1.Lines Do
      Begin
        Clear;
        { Datei-Informationen holen }
        If GetFileInfo (OpenDialog1.FileName, FileInfo) Then
          With FileInfo Do
            Begin
              Add ('Datei: ' + OpenDialog1.FileName);
              Add ('');
              Add ('Version: ' + FileInfoVersionToStr (Version));
              Add ('Type: ' + FileInfoTypeToStr (FileType));
              Add ('');
              For Loop := Low (Loop) To High (Loop) Do
                If SpecificAspect [Loop] <> '' Then
                  Add (FileInfoSpecificAspectToStr (Loop) + ': ' + SpecificAspect [Loop]);
            End
          Else
            Add ('Fehler');
        End;
End;					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:

function FileInfoVersionToStr (aVersion: tFileInfoVersion): String;
Begin
  With aVersion Do
    Begin
      Result := IntToStr (Major);
      Result := Result + '.' + IntToStr (Minor);
      Result := Result + '.' + IntToStr (Release);
      Result := Result + '.' + IntToStr (Build);
    End;
End;

Function FileInfoBuildToStr (aBuild: tFileInfoBuild): String;
Const
  cStr : Array [tFileInfoBuild] Of String = (
      'Debug', 'Prerelease', 'Patched', 'Private build', 'Info infered', 'Special build'
    );
Begin
  FileInfoBuildToStr := cStr [aBuild]
End;

Function FileInfoTypeToStr (aType: tFileInfoType): String;
Const
  cStr : Array [tFileInfoType] Of String = (
      'Unknow', 'Application', 'Dynamiclink Library', 'Device Driver',
      'Font', 'Virtual Device', 'Staticlink Library'
    );
Begin
  FileInfoTypeToStr := cStr [aType];
End;

Function FileInfoSpecificAspectToStr (aAspect: tFileInfoSpecificAspect): String;
Const
  cStr : Array [tFileInfoSpecificAspect] Of String = (
      'Company Name', 'File Description', 'File Version', 'Internal Name',
      'Legal Copyright', 'Legal Trademarks', 'Original Filename',
      'Private Build', 'Product Name', 'Product Version', 'Special Build',
      'Comments'
    );
Begin
  FileInfoSpecificAspectToStr := cStr [aAspect];
End;