VBA Tipp: Versionsinformation einer Datei ermitteln

Aus DBWiki
Wechseln zu: Navigation, Suche

Problem

Ich möchte die Versionsinformation einer bestimmten Datei ermitteln.

Lösung

Dabei helfen folgende Funktionen, die die VERSION.DLL nutzen:

Type VS_FIXEDFILEINFO
   dwSignature As Long
   dwStrucVersionl As Integer     '  e.g. = &h0000 = 0
   dwStrucVersionh As Integer     '  e.g. = &h0042 = .42
   dwFileVersionMSl As Integer    '  e.g. = &h0003 = 3
   dwFileVersionMSh As Integer    '  e.g. = &h0075 = .75
   dwFileVersionLSl As Integer    '  e.g. = &h0000 = 0
   dwFileVersionLSh As Integer    '  e.g. = &h0031 = .31
   dwProductVersionMSl As Integer '  e.g. = &h0003 = 3
   dwProductVersionMSh As Integer '  e.g. = &h0010 = .1
   dwProductVersionLSl As Integer '  e.g. = &h0000 = 0
   dwProductVersionLSh As Integer '  e.g. = &h0031 = .31
   dwFileFlagsMask As Long        '  = &h3F for version "0.42"
   dwFileFlags As Long            '  e.g. VFF_DEBUG Or VFF_PRERELEASE
   dwFileOS As Long               '  e.g. VOS_DOS_WINDOWS16
   dwFileType As Long             '  e.g. VFT_DRIVER
   dwFileSubtype As Long          '  e.g. VFT2_DRV_KEYBOARD
   dwFileDateMS As Long           '  e.g. 0
   dwFileDateLS As Long           '  e.g. 0
End Type
 
Declare Function GetFileVersionInfo Lib "Version.dll" Alias _
   "GetFileVersionInfoA" (ByVal lptstrFilename As String, ByVal _
   dwhandle As Long, ByVal dwlen As Long, lpData As Any) As Long
Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias _
   "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, _
   lpdwHandle As Long) As Long
Declare Function VerQueryValue Lib "Version.dll" Alias _
   "VerQueryValueA" (pBlock As Any, ByVal lpSubBlock As String, _
   lplpBuffer As Any, puLen As Long) As Long
Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (dest As Any, ByVal SouRetVale As Long, ByVal Length As Long)
Declare Function GetSystemDirectory Lib "kernel32" Alias _
   "GetSystemDirectoryA" (ByVal Path As String, ByVal cbBytes As Long) As Long
 
' Deklarationen aus Win32 VER.H
' ----- VS_VERSION.dwFileFlags -----
 
Public Const VS_FFI_SIGNATURE = &HFEEF04BD
Public Const VS_FFI_STRUCVERSION = &H10000
Public Const VS_FFI_FILEFLAGSMASK = &H3F&
 
' ----- VS_VERSION.dwFileFlags -----
Public Const VS_FF_DEBUG = &H1
Public Const VS_FF_PRERELEASE = &H2
Public Const VS_FF_PATCHED = &H4
Public Const VS_FF_PRIVATEBUILD = &H8
Public Const VS_FF_INFOINFERRED = &H10
Public Const VS_FF_SPECIALBUILD = &H20
 
' ----- VS_VERSION.dwFileOS -----
Public Const VOS_UNKNOWN = &H0
Public Const VOS_DOS = &H10000
Public Const VOS_OS216 = &H20000
Public Const VOS_OS232 = &H30000
Public Const VOS_NT = &H40000
 
Public Const VOS__BASE = &H0
Public Const VOS__WINDOWS16 = &H1
Public Const VOS__PM16 = &H2
Public Const VOS__PM32 = &H3
Public Const VOS__WINDOWS32 = &H4
 
Public Const VOS_DOS_WINDOWS16 = &H10001
Public Const VOS_DOS_WINDOWS32 = &H10004
Public Const VOS_OS216_PM16 = &H20002
Public Const VOS_OS232_PM32 = &H30003
Public Const VOS_NT_WINDOWS32 = &H40004
 
' ----- VS_VERSION.dwFileType -----
Public Const VFT_UNKNOWN = &H0
Public Const VFT_APP = &H1
Public Const VFT_DLL = &H2
Public Const VFT_DRV = &H3
Public Const VFT_FONT = &H4
Public Const VFT_VXD = &H5
Public Const VFT_STATIC_LIB = &H7
 
' ----- VS_VERSION.dwFileSubtype for VFT_WINDOWS_DRV -----
Public Const VFT2_UNKNOWN = &H0
Public Const VFT2_DRV_PRINTER = &H1
Public Const VFT2_DRV_KEYBOARD = &H2
Public Const VFT2_DRV_LANGUAGE = &H3
Public Const VFT2_DRV_DISPLAY = &H4
Public Const VFT2_DRV_MOUSE = &H5
Public Const VFT2_DRV_NETWORK = &H6
Public Const VFT2_DRV_SYSTEM = &H7
Public Const VFT2_DRV_INSTALLABLE = &H8
Public Const VFT2_DRV_SOUND = &H9
Public Const VFT2_DRV_COMM = &HA
 
Public Const VFT2_FONT_RASTER = &H1
Public Const VFT2_FONT_VECTOR = &H2
Public Const VFT2_FONT_TRUETYPE = &H3
 
Private udtVerBuffer As VS_FIXEDFILEINFO
 
Private Function GetVerInfo(FName As String) As Boolean
'*** Get Version Info ****
 
  Dim RetVal            As Long
  Dim lDummy            As Long
  Dim sBuffer()         As Byte
  Dim lBufferLen        As Long
  Dim lVerPointer       As Long
  Dim lVerBufferLen     As Long
  Dim sCurrentFName As String
  Dim sSystemDirPath As String
 
  sCurrentFName = FName
 
  If InStr(sCurrentFName, "\") = 0 Then
  ' **** If no directory information, use Windows System Subdirectory ****
    sSystemDirPath = String$(256, 0)
    RetVal = GetSystemDirectory(sSystemDirPath, Len(sSystemDirPath))
    sSystemDirPath = LCase$(Mid$(sSystemDirPath, 1, _
                     InStr(sSystemDirPath, Chr(0)) - 1))
    sCurrentFName = sSystemDirPath & "\" & sCurrentFName
  End If
  '*** Get size ****
  lBufferLen = GetFileVersionInfoSize(FName, lDummy)
  If lBufferLen < 1 Then
    GetVerInfo = False
  Else
    '**** Store info to udtVerBuffer struct ****
    ReDim sBuffer(lBufferLen)
    RetVal = GetFileVersionInfo(FName, 0&, lBufferLen, sBuffer(0))
    RetVal = VerQueryValue(sBuffer(0), "\", lVerPointer, lVerBufferLen)
    MoveMemory udtVerBuffer, lVerPointer, Len(udtVerBuffer)
    GetVerInfo = True
  End If
End Function
 
Public Function GetFileVersionNumber(FName As String) As String
  '**** Determine File Version number ****
  If GetVerInfo(FName) Then
    GetFileVersionNumber = Format$(udtVerBuffer.dwFileVersionMSh) & "." & _
      Format$(udtVerBuffer.dwFileVersionMSl) & "." & _
      Format$(udtVerBuffer.dwFileVersionLSh) & "." & _
      Format$(udtVerBuffer.dwFileVersionLSl)
  Else
    GetFileVersionNumber = ""
  End If
End Function
 
Public Function GetProductVersionNumber(FName As String) As String
  '**** Determine Product Version number ****
  If GetVerInfo(FName) Then
    GetProductVersionNumber = Format$(udtVerBuffer.dwProductVersionMSh) & "." & _
      Format$(udtVerBuffer.dwProductVersionMSl) & "." & _
      Format$(udtVerBuffer.dwProductVersionLSh) & "." & _
      Format$(udtVerBuffer.dwProductVersionLSl)
  Else
    GetProductVersionNumber = ""
  End If
End Function
 
Public Function GetFileAttributes(FName As String) As String
Dim FileFlags As String
  '**** Determine Boolean attributes of File ****
  FileFlags = ""
  If GetVerInfo(FName) Then
    If udtVerBuffer.dwFileFlags And VS_FF_DEBUG _
       Then FileFlags = "Debug "
    If udtVerBuffer.dwFileFlags And VS_FF_PRERELEASE _
       Then FileFlags = FileFlags & "PreRel "
    If udtVerBuffer.dwFileFlags And VS_FF_PATCHED _
       Then FileFlags = FileFlags & "Patched "
    If udtVerBuffer.dwFileFlags And VS_FF_PRIVATEBUILD _
       Then FileFlags = FileFlags & "Private "
    If udtVerBuffer.dwFileFlags And VS_FF_INFOINFERRED _
       Then FileFlags = FileFlags & "Info "
    If udtVerBuffer.dwFileFlags And VS_FF_SPECIALBUILD _
       Then FileFlags = FileFlags & "Special "
    If udtVerBuffer.dwFileFlags And VFT2_UNKNOWN _
       Then FileFlags = FileFlags & "Unknown "
  End If
  GetFileAttributes = FileFlags
End Function
 
Public Function GetOSVersion(FName As String) As String
  '**** Determine OS for which file was designed ****
  If GetVerInfo(FName) Then
    Select Case udtVerBuffer.dwFileOS
       Case VOS_DOS_WINDOWS16
         GetOSVersion = "DOS-Win16"
       Case VOS_DOS_WINDOWS32
         GetOSVersion = "DOS-Win32"
       Case VOS_OS216_PM16
         GetOSVersion = "OS/2-16 PM-16"
       Case VOS_OS232_PM32
         GetOSVersion = "OS/2-16 PM-32"
       Case VOS_NT_WINDOWS32
         GetOSVersion = "NT-Win32"
       Case Else
         GetOSVersion = "Unknown"
    End Select
  Else
    GetOSVersion = ""
  End If
End Function
 
Public Function GetFileType(FName As String) As String
'**** Determine file type ****
Dim FileType As String, FileSubType As String, Res As String
  FileType = ""
  FileSubType = ""
  Res = ""
  If GetVerInfo(FName) Then
    Select Case udtVerBuffer.dwFileType
    Case VFT_APP
      FileType = "App"
    Case VFT_DLL
      FileType = "DLL"
    Case VFT_DRV
      FileType = "Driver"
      Select Case udtVerBuffer.dwFileSubtype
        Case VFT2_DRV_PRINTER
          FileSubType = "Printer drv"
        Case VFT2_DRV_KEYBOARD
          FileSubType = "Keyboard drv"
        Case VFT2_DRV_LANGUAGE
          FileSubType = "Language drv"
        Case VFT2_DRV_DISPLAY
          FileSubType = "Display drv"
        Case VFT2_DRV_MOUSE
          FileSubType = "Mouse drv"
        Case VFT2_DRV_NETWORK
          FileSubType = "Network drv"
        Case VFT2_DRV_SYSTEM
          FileSubType = "System drv"
        Case VFT2_DRV_INSTALLABLE
          FileSubType = "Installable"
        Case VFT2_DRV_SOUND
          FileSubType = "Sound drv"
        Case VFT2_DRV_COMM
          FileSubType = "Comm drv"
        Case VFT2_UNKNOWN
          FileSubType = "Unknown"
      End Select
    Case VFT_FONT
      FileType = "Font"
      Select Case udtVerBuffer.dwFileSubtype
        Case VFT2_FONT_RASTER
          FileSubType = "Raster Font"
        Case VFT2_FONT_VECTOR
          FileSubType = "Vector Font"
        Case VFT2_FONT_TRUETYPE
          FileSubType = "TrueType Font"
      End Select
    Case VFT_VXD
      FileType = "VxD"
    Case VFT_STATIC_LIB
      FileType = "Lib"
    Case Else
      FileType = "Unbekannt"
    End Select
  End If
  Res = FileType
  If FileSubType <> "" Then Res = Res & ": " & FileSubType
  GetFileType = Res
End Function

Aufruf

GetFileVersionNumber("C:\WinNT\System32\RasMon.exe")
 
' Rückgabe:
4.0.1381.273
GetOSVersion("C:\WinNT\System32\Ping.exe")
 
' Rückgabe:
NT-Win32

Die Funktionen im Überblick

Funktionsname Rückgabe
GetFileVersionNumber Dateiversion
GetProductVersionNumber Produktversion
GetOSVersion Betriebssystem / Version
GetFileType Dateityp: Executable, DLL, Treiber

Weblinks

Microsoft Knowledge Base Artikel Q139491: