Planet Source Code Jumbo …e CD Visual Basic 1 to 7/1_2002.ISO/Data/Zips/CODE_UPLOAD88928122000.psc/CFileVersionInfo.cls

Visual Basic class definition | 1998-08-20 | 17.4 KB | 503 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "CFileVersionInfo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
' *********************************************************************
'  Copyright (C)1995-98 Karl E. Peterson, All Rights Reserved
'  http://www.mvps.org/vb
' *********************************************************************
'  Warning: This computer program is protected by copyright law and
'  international treaties. Unauthorized reproduction or distribution
'  of this program, or any portion of it, may result in severe civil
'  and criminal penalties, and will be prosecuted to the maximum
'  extent possible under the law.
' *********************************************************************
Option Explicit
'
' API declarations
'
Private Declare Function GetFullPathName Lib "kernel32" Alias "GetFullPathNameA" (ByVal lpFileName As String, ByVal nBufferLength As Long, ByVal lpBuffer As String, lpFilePart As Long) As Long
Private 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
Private Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" (pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
Private Declare Function VerLanguageName Lib "kernel32" Alias "VerLanguageNameA" (ByVal wLang As Long, ByVal szLang As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal Path As String, ByVal cbBytes As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
'
' API structures.
'
Private 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
'
' API constants.
'
Private Const MAX_PATH = 260
' ----- VS_VERSION.dwFileFlags -----
Private Const VS_FFI_SIGNATURE = &HFEEF04BD
Private Const VS_FFI_STRUCVERSION = &H10000
Private Const VS_FFI_FILEFLAGSMASK = &H3F&
' ----- VS_VERSION.dwFileFlags -----
Private Const VS_FF_DEBUG = &H1
Private Const VS_FF_PRERELEASE = &H2
Private Const VS_FF_PATCHED = &H4
Private Const VS_FF_PRIVATEBUILD = &H8
Private Const VS_FF_INFOINFERRED = &H10
Private Const VS_FF_SPECIALBUILD = &H20
' ----- VS_VERSION.dwFileOS -----
Private Const VOS_UNKNOWN = &H0
Private Const VOS_DOS = &H10000
Private Const VOS_OS216 = &H20000
Private Const VOS_OS232 = &H30000
Private Const VOS_NT = &H40000
Private Const VOS_DOS_WINDOWS16 = &H10001
Private Const VOS_DOS_WINDOWS32 = &H10004
Private Const VOS_OS216_PM16 = &H20002
Private Const VOS_OS232_PM32 = &H30003
Private Const VOS_NT_WINDOWS32 = &H40004
' ----- VS_VERSION.dwFileType -----
Private Const VFT_UNKNOWN = &H0
Private Const VFT_APP = &H1
Private Const VFT_DLL = &H2
Private Const VFT_DRV = &H3
Private Const VFT_FONT = &H4
Private Const VFT_VXD = &H5
Private Const VFT_STATIC_LIB = &H7
' **** VS_VERSION.dwFileSubtype for VFT_WINDOWS_FONT ****
Private Const VFT2_FONT_RASTER = &H1&
Private Const VFT2_FONT_VECTOR = &H2&
Private Const VFT2_FONT_TRUETYPE = &H3&
' ----- VS_VERSION.dwFileSubtype for VFT_WINDOWS_DRV -----
Private Const VFT2_UNKNOWN = &H0
Private Const VFT2_DRV_PRINTER = &H1
Private Const VFT2_DRV_KEYBOARD = &H2
Private Const VFT2_DRV_LANGUAGE = &H3
Private Const VFT2_DRV_DISPLAY = &H4
Private Const VFT2_DRV_MOUSE = &H5
Private Const VFT2_DRV_NETWORK = &H6
Private Const VFT2_DRV_SYSTEM = &H7
Private Const VFT2_DRV_INSTALLABLE = &H8
Private Const VFT2_DRV_SOUND = &H9
Private Const VFT2_DRV_COMM = &HA
'
' Member variables.
'
Private m_PathName As String
Private m_Available As Boolean
Private m_StrucVer As String     ' Structure Version - NOT USED
Private m_FileVer As String      ' File Version
Private m_ProdVer As String      ' Product Version
Private m_FileFlags As String    ' Boolean attributes of file
Private m_FileOS As String       ' OS file is designed for
Private m_FileType As String     ' Type of file
Private m_FileSubType As String  ' Sub-type of file
Private m_VerLanguage As String
Private m_VerCompany As String
Private m_VerDescription As String
Private m_VerFileVer As String
Private m_VerInternalName As String
Private m_VerCopyright As String
Private m_VerTrademarks As String
Private m_VerOrigFilename As String
Private m_VerProductName As String
Private m_VerProductVer As String

' ********************************************
'  Initialize and Terminate
' ********************************************
Private Sub Class_Initialize()
   '
   ' All member variables can be left to defaults.
   '
End Sub

Private Sub Class_Terminate()
   '
   ' No special cleanup required.
   '
End Sub

' ********************************************
'  Public Properties
' ********************************************
Public Property Let FullPathName(ByVal NewVal As String)
   Dim Buffer As String
   Dim nFilePart As Long
   Dim nRet As Long
   '
   ' Retrieve fully qualified path/name specs.
   '
   Buffer = Space(MAX_PATH)
   nRet = GetFullPathName(NewVal, Len(Buffer), Buffer, nFilePart)
   If nRet Then
      m_PathName = Left(Buffer, nRet)
      Refresh
   End If
End Property

Public Property Get FullPathName() As String
   ' Returns fully-qualified path/name spec.
   FullPathName = m_PathName
End Property

Public Property Get Available() As Boolean
   ' Returns whether version information is available
   Available = m_Available
End Property

' ********************************************
'  Standard Version Information
' ********************************************
Public Property Get FileFlags() As String
   FileFlags = m_FileFlags
End Property

Public Property Get FileOS() As String
   FileOS = m_FileOS
End Property

Public Property Get FileType() As String
   FileType = m_FileType
End Property

Public Property Get FileSubType() As String
   FileSubType = m_FileSubType
End Property

Public Property Get VerFile() As String
   VerFile = m_FileVer
End Property

Public Property Get VerProduct() As String
   VerProduct = m_ProdVer
End Property

Public Property Get VerStructure() As String
   VerStructure = m_StrucVer
End Property

' ********************************************
'  Better Version Information
' ********************************************
Public Property Get CompanyName() As String
   CompanyName = m_VerCompany
End Property

Public Property Get FileDescription() As String
   FileDescription = m_VerDescription
End Property

Public Property Get FileVersion() As String
   FileVersion = m_VerFileVer
End Property

Public Property Get InternalName() As String
   InternalName = m_VerInternalName
End Property

Public Property Get Language() As String
   Language = m_VerLanguage
End Property

Public Property Get LegalCopyright() As String
   LegalCopyright = m_VerCopyright
End Property

Public Property Get LegalTrademarks() As String
   LegalTrademarks = m_VerTrademarks
End Property

Public Property Get OriginalFilename() As String
   OriginalFilename = m_VerOrigFilename
End Property

Public Property Get ProductName() As String
   ProductName = m_VerProductName
End Property

Public Property Get ProductVersion() As String
   ProductVersion = m_VerProductVer
End Property

' ********************************************
'  Public Methods
' ********************************************
Public Sub Refresh()
   Dim nDummy As Long
   Dim nRet As Long
   Dim sBuffer()         As Byte
   Dim lBufferLen        As Long
   Dim lplpBuffer       As Long
   Dim udtVerBuffer      As VS_FIXEDFILEINFO
   Dim puLen     As Long
   Dim sBlock As String
   Dim sTemp As String
   '
   ' Get size
   '
   lBufferLen = GetFileVersionInfoSize(m_PathName, nDummy)
   If lBufferLen Then
      m_Available = True
   Else
      m_Available = False
      Exit Sub
   End If
   '
   ' Store info to udtVerBuffer struct
   '
   ReDim sBuffer(lBufferLen)
   Call GetFileVersionInfo(m_PathName, 0&, lBufferLen, sBuffer(0))
   Call VerQueryValue(sBuffer(0), "\", lplpBuffer, puLen)
   Call CopyMem(udtVerBuffer, ByVal lplpBuffer, Len(udtVerBuffer))
   '
   ' Determine Structure Version number - NOT USED
   '
   m_StrucVer = Format$(udtVerBuffer.dwStrucVersionh) & "." & _
      Format$(udtVerBuffer.dwStrucVersionl)
   '
   ' Determine File Version number
   '
   m_FileVer = Format$(udtVerBuffer.dwFileVersionMSh) & "." & _
      Format$(udtVerBuffer.dwFileVersionMSl, "00") & "."
   If udtVerBuffer.dwFileVersionLSh > 0 Then
      m_FileVer = m_FileVer & Format$(udtVerBuffer.dwFileVersionLSh, "00") & _
         Format$(udtVerBuffer.dwFileVersionLSl, "00")
   Else
      m_FileVer = m_FileVer & Format$(udtVerBuffer.dwFileVersionLSl, "0000")
   End If
   '
   ' Determine Product Version number
   '
   m_ProdVer = Format$(udtVerBuffer.dwProductVersionMSh) & "." & _
      Format$(udtVerBuffer.dwProductVersionMSl, "00") & "."
   If udtVerBuffer.dwProductVersionLSh > 0 Then
      m_ProdVer = m_ProdVer & Format$(udtVerBuffer.dwProductVersionLSh, "00") & _
         Format$(udtVerBuffer.dwProductVersionLSl, "00")
   Else
      m_ProdVer = m_ProdVer & Format$(udtVerBuffer.dwProductVersionLSl, "0000")
   End If
   '
   ' Determine Boolean attributes of File
   '
   m_FileFlags = ""
   If udtVerBuffer.dwFileFlags And VS_FF_DEBUG _
      Then m_FileFlags = "Debug "
   If udtVerBuffer.dwFileFlags And VS_FF_PRERELEASE _
      Then m_FileFlags = m_FileFlags & "PreRel "
   If udtVerBuffer.dwFileFlags And VS_FF_PATCHED _
      Then m_FileFlags = m_FileFlags & "Patched "
   If udtVerBuffer.dwFileFlags And VS_FF_PRIVATEBUILD _
      Then m_FileFlags = m_FileFlags & "Private "
   If udtVerBuffer.dwFileFlags And VS_FF_INFOINFERRED _
      Then m_FileFlags = m_FileFlags & "Info "
   If udtVerBuffer.dwFileFlags And VS_FF_SPECIALBUILD _
      Then m_FileFlags = m_FileFlags & "Special "
   If udtVerBuffer.dwFileFlags And VFT2_UNKNOWN _
      Then m_FileFlags = m_FileFlags + "Unknown "
   m_FileFlags = Trim(m_FileFlags)
   '
   ' Determine OS for which file was designed
   '
   Select Case udtVerBuffer.dwFileOS
      Case VOS_DOS_WINDOWS16
        m_FileOS = "DOS-Win16"
      Case VOS_DOS_WINDOWS32
        m_FileOS = "DOS-Win32"
      Case VOS_OS216_PM16
        m_FileOS = "OS/2-16 PM-16"
      Case VOS_OS232_PM32
        m_FileOS = "OS/2-16 PM-32"
      Case VOS_NT_WINDOWS32
        m_FileOS = "NT-Win32"
      Case Else
        m_FileOS = "Unknown"
   End Select
   '
   ' Determine type of file
   '
   Select Case udtVerBuffer.dwFileType
      Case VFT_APP
         m_FileType = "Application"
      Case VFT_DLL
         m_FileType = "DLL"
      Case VFT_DRV
         m_FileType = "Driver"
         Select Case udtVerBuffer.dwFileSubtype
            Case VFT2_DRV_PRINTER
               m_FileSubType = "Printer drv"
            Case VFT2_DRV_KEYBOARD
               m_FileSubType = "Keyboard drv"
            Case VFT2_DRV_LANGUAGE
               m_FileSubType = "Language drv"
            Case VFT2_DRV_DISPLAY
               m_FileSubType = "Display drv"
            Case VFT2_DRV_MOUSE
               m_FileSubType = "Mouse drv"
            Case VFT2_DRV_NETWORK
               m_FileSubType = "Network drv"
            Case VFT2_DRV_SYSTEM
               m_FileSubType = "System drv"
            Case VFT2_DRV_INSTALLABLE
               m_FileSubType = "Installable"
            Case VFT2_DRV_SOUND
               m_FileSubType = "Sound drv"
            Case VFT2_DRV_COMM
               m_FileSubType = "Comm drv"
            Case VFT2_UNKNOWN
               m_FileSubType = "Unknown"
         End Select
      Case VFT_FONT
         m_FileType = "Font"
         Select Case udtVerBuffer.dwFileSubtype
            Case VFT2_FONT_RASTER
               m_FileSubType = "Raster Font"
            Case VFT2_FONT_VECTOR
               m_FileSubType = "Vector Font"
            Case VFT2_FONT_TRUETYPE
               m_FileSubType = "TrueType Font"
         End Select
      Case VFT_VXD
         m_FileType = "VxD"
      Case VFT_STATIC_LIB
         m_FileType = "Lib"
      Case Else
         m_FileType = "Unknown"
   End Select
   '
   ' Get language translations
   '
   If VerQueryValue(sBuffer(0), "\VarFileInfo\Translation", lplpBuffer, puLen) Then
      If puLen Then
         sTemp = PointerToStringB(lplpBuffer, puLen)
         sTemp = Right("0" & Hex(Asc(Mid(sTemp, 2, 1))), 2) & _
                 Right("0" & Hex(Asc(Mid(sTemp, 1, 1))), 2) & _
                 Right("0" & Hex(Asc(Mid(sTemp, 4, 1))), 2) & _
                 Right("0" & Hex(Asc(Mid(sTemp, 3, 1))), 2)
         sBlock = "\StringFileInfo\" & sTemp & "\"
         '
         ' Determine language
         '
         m_VerLanguage = Space(256)
         nRet = VerLanguageName(CLng("&H" & Left(sTemp, 4)), m_VerLanguage, Len(m_VerLanguage))
         If nRet Then
            m_VerLanguage = Left(m_VerLanguage, nRet)
         Else
            m_VerLanguage = ""
         End If
         '
         ' Get predefined version resources
         '
         If VerQueryValue(sBuffer(0), sBlock & "CompanyName", lplpBuffer, puLen) Then
            If puLen Then
               m_VerCompany = PointerToString(lplpBuffer)
            End If
         End If
         If VerQueryValue(sBuffer(0), sBlock & "FileDescription", lplpBuffer, puLen) Then
            If puLen Then
               m_VerDescription = PointerToString(lplpBuffer)
            End If
         End If
         If VerQueryValue(sBuffer(0), sBlock & "FileVersion", lplpBuffer, puLen) Then
            If puLen Then
               m_VerFileVer = PointerToString(lplpBuffer)
            End If
         End If
         If VerQueryValue(sBuffer(0), sBlock & "InternalName", lplpBuffer, puLen) Then
            If puLen Then
               m_VerInternalName = PointerToString(lplpBuffer)
            End If
         End If
         If VerQueryValue(sBuffer(0), sBlock & "LegalCopyright", lplpBuffer, puLen) Then
            If puLen Then
               m_VerCopyright = PointerToString(lplpBuffer)
            End If
         End If
         If VerQueryValue(sBuffer(0), sBlock & "LegalTrademarks", lplpBuffer, puLen) Then
            If puLen Then
               m_VerTrademarks = PointerToString(lplpBuffer)
            End If
         End If
         If VerQueryValue(sBuffer(0), sBlock & "OriginalFilename", lplpBuffer, puLen) Then
            If puLen Then
               m_VerOrigFilename = PointerToString(lplpBuffer)
            End If
         End If
         If VerQueryValue(sBuffer(0), sBlock & "ProductName", lplpBuffer, puLen) Then
            If puLen Then
               m_VerProductName = PointerToString(lplpBuffer)
            End If
         End If
         If VerQueryValue(sBuffer(0), sBlock & "ProductVersion", lplpBuffer, puLen) Then
            If puLen Then
               m_VerProductVer = PointerToString(lplpBuffer)
            End If
         End If
      End If
   End If
End Sub

' ********************************************
'  Private Methods
' ********************************************
Private Function PointerToStringW(lpStringW As Long) As String
   Dim Buffer() As Byte
   Dim nLen As Long

   If lpStringW Then
      nLen = lstrlenW(lpStringW) * 2
      If nLen Then
         ReDim Buffer(0 To (nLen - 1)) As Byte
         CopyMem Buffer(0), ByVal lpStringW, nLen
         PointerToStringW = Buffer
      End If
   End If
End Function

Private Function PointerToString(lpString As Long) As String
   Dim Buffer As String
   Dim nLen As Long

   If lpString Then
      nLen = lstrlenA(lpString)
      If nLen Then
         Buffer = Space(nLen)
         CopyMem ByVal Buffer, ByVal lpString, nLen
         PointerToString = Buffer
      End If
   End If
End Function

Private Function PointerToStringB(lpString As Long, nBytes As Long) As String
   Dim Buffer As String

   If nBytes Then
      Buffer = Space(nBytes)
      CopyMem ByVal Buffer, ByVal lpString, nBytes
      PointerToStringB = Buffer
   End If
End Function