Вот и не только определения версии(разбито на 2 потому что не влазит :

1-я часть

'***********************************************************
'Класс обработки версии файла. Компонент OS Reporter
'***********************************************************
'Автор: Андрей 'd1' Перминов
'E-Mail: d1pro@mail.ru
'Team HW 2002
'Web: hw.hotbox.ru
'***********************************************************
Option Explicit
Private Declare Function GetLocaleInfoA Lib "kernel32.dll" (ByVal lLCID As Long, ByVal lLCTYPE As Long, ByVal strLCData As String, ByVal lDataLen As Long) As Long
Private Declare Sub lstrcpyn Lib "kernel32.dll" (ByVal strDest As String, ByVal strSrc As Any, ByVal lBytes As Long)
Private Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" (ByVal sFile As String, lpLen As Long) As Long
Private Declare Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" (ByVal sFile As String, ByVal lpIgnored As Long, ByVal lpSize As Long, ByVal lpBuf As Long) As Long
Private Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" (ByVal lpBuf As Long, ByVal szReceive As String, lpBufPtr As Long, lLen As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal ByteLen As Long)
Private Declare Function GetUserDefaultLCID Lib "kernel32.dll" () As Long
 
Private Enum FileInfoStruct
    FileVersion = 0
    FileDescription = 1
    FSComments = 2
    FSCompanyName = 3
    FSInternalName = 4
    FSLegalCopyright = 5
    FSLegalTrademarks = 6
    FSOriginalFilename = 7
    FSProductName = 8
    FSProductVersion = 9
    FSPrivateBuild = 10
    FSSpecialBuild = 11
End Enum
 
Public FileName As String
 
Public Property Get Version() As String
    If Not Len(FileName) = 0 Then Version = GetFileInfo(FileName, FileVersion)
End Property
 
Public Property Get Description() As String
    If Not Len(FileName) = 0 Then Description = GetFileInfo(FileName, FileDescription)
End Property
 
Public Property Get Comments() As String
    If Not Len(FileName) = 0 Then Comments = GetFileInfo(FileName, FSComments)
End Property
 
Public Property Get CompanyName() As String
    If Not Len(FileName) = 0 Then CompanyName = GetFileInfo(FileName, FSCompanyName)
End Property
 
Public Property Get InternalName() As String
    If Not Len(FileName) = 0 Then InternalName = GetFileInfo(FileName, FSInternalName)
End Property
 
Public Property Get LegalCopyright() As String
    If Not Len(FileName) = 0 Then LegalCopyright = GetFileInfo(FileName, FSLegalCopyright)
End Property
 
Public Property Get LegalTrademarks() As String
    If Not Len(FileName) = 0 Then LegalTrademarks = GetFileInfo(FileName, FSLegalTrademarks)
End Property
 
Public Property Get OriginalFilename() As String
    If Not Len(FileName) = 0 Then OriginalFilename = GetFileInfo(FileName, FSOriginalFilename)
End Property
 
Public Property Get ProductName() As String
    If Not Len(FileName) = 0 Then ProductName = GetFileInfo(FileName, FSProductName)
End Property
 
Public Property Get ProductVersion() As String
    If Not Len(FileName) = 0 Then ProductVersion = GetFileInfo(FileName, FSProductVersion)
End Property
 
Public Property Get PrivateBuild() As String
    If Not Len(FileName) = 0 Then PrivateBuild = GetFileInfo(FileName, FSPrivateBuild)
End Property
 
Public Property Get SpecialBuild() As String
    If Not Len(FileName) = 0 Then SpecialBuild = GetFileInfo(FileName, FSSpecialBuild)
End Property
 
Private Function StringFromBuffer(Buffer As String) As String
    Dim nPos As Long
    nPos = InStr(Buffer, vbNullChar)
    If nPos > 0 Then StringFromBuffer = Left$(Buffer, nPos - 1)
End Function
 
Private Function GetFileInfoKey(ByVal sFile As String, Info() As Byte) As String
    Dim lVerSize    As Long, lTemp  As Long, lRet   As Long
    
    lVerSize = GetFileVersionInfoSize(sFile, lTemp)
    ReDim Info(lVerSize)
    If Not lVerSize > 0 Then Exit Function
    
    lRet = GetFileVersionInfo(sFile, lTemp, lVerSize, VarPtr(Info(0)))
    If Not lRet = 0 Then GetFileInfoKey = GetNLSKey(Info)
End Function

Ответить

2-я часть класса

Private Function GetFileInfo(ByVal sFile As String, Info As FileInfoStruct) As String
    Dim lVerSize    As Long, lTemp  As Long, lRet   As Long, lpBuffer   As Long
    Dim bInfo()     As Byte
    Dim sDesc       As String, sKEY As String
    
    sKEY = GetFileInfoKey(sFile, bInfo())
    
    Select Case Info
        Case Is = FileVersion
            sKEY = sKEY & "\FileVersion"
        Case Is = FileDescription
            sKEY = sKEY & "\FileDescription"
        Case Is = FSComments
            sKEY = sKEY & "\Comments"
        Case Is = FSCompanyName
            sKEY = sKEY & "\CompanyName"
        Case Is = FSInternalName
            sKEY = sKEY & "\InternalName"
        Case Is = FSLegalCopyright
            sKEY = sKEY & "\LegalCopyright"
        Case Is = FSLegalTrademarks
            sKEY = sKEY & "\LegalTrademarks"
        Case Is = FSOriginalFilename
            sKEY = sKEY & "\OriginalFilename"
        Case Is = FSProductName
            sKEY = sKEY & "\ProductName"
        Case Is = FSProductVersion
            sKEY = sKEY & "\ProductVersion"
        Case Is = FSPrivateBuild
            sKEY = sKEY & "\PrivateBuild"
        Case Is = FSSpecialBuild
            sKEY = sKEY & "\SpecialBuild"
    End Select
    If VerQueryValue(VarPtr(bInfo(0)), sKEY, lpBuffer, lVerSize) = 0 Then Exit Function
    sDesc = Space$(lVerSize)
    lstrcpyn sDesc, lpBuffer, lVerSize
    GetFileInfo = StringFromBuffer(sDesc)
End Function
 
Private Function GetNLSKey(ByteVerData() As Byte) As String
    Static strLANGCP As String, lpBufPtr                As Long
    Dim strNLSKey   As String, strTmp                   As String
    Dim fGotNLSKey  As Integer, intOffset               As Integer
    Dim lVerSize    As Long, lTmp   As Long, lBufLen    As Long, lLCID  As Long
    
    On Error GoTo GNLSKCleanup
    If VerQueryValue(VarPtr(ByteVerData(0)), "\VarFileInfo\Translation", lpBufPtr, lVerSize) <> 0 Then
        If Len(strLANGCP) = 0 Then
            lLCID = GetUserDefaultLCID()
            If lLCID > 0 Then
                strTmp = Space$(8)
                GetLocaleInfoA lLCID, 11, strTmp, 8
                strLANGCP = StringFromBuffer(strTmp)
                Do While Len(strLANGCP) < 4
                    strLANGCP = "0" & strLANGCP
                Loop
                GetLocaleInfoA lLCID, 9, strTmp, 8
                strLANGCP = StringFromBuffer(strTmp) & strLANGCP
                Do While Len(strLANGCP) < 8
                    strLANGCP = "0" & strLANGCP
                Loop
            End If
        End If
        If VerQueryValue(VarPtr(ByteVerData(0)), strLANGCP, lTmp, lBufLen) <> 0 Then
            strNLSKey = strLANGCP
        Else
            For intOffset = 0 To lVerSize - 1 Step 4
            CopyMemory lTmp, ByVal lpBufPtr + intOffset, 4
            strTmp = Hex$(lTmp)
            Do While Len(strTmp) < 8
                strTmp = "0" & strTmp
            Loop
            strNLSKey = "\StringFileInfo\" & Right$(strTmp, 4) & Left$(strTmp, 4)
            If VerQueryValue(VarPtr(ByteVerData(0)), strNLSKey, lTmp, lBufLen) <> 0 Then
                fGotNLSKey = True
                Exit For
            End If
            Next
            If Not fGotNLSKey Then
                strNLSKey = "\StringFileInfo\040904E4"
                If VerQueryValue(VarPtr(ByteVerData(0)), strNLSKey, lTmp, lBufLen) <> 0 Then
                    fGotNLSKey = True
                End If
            End If
        End If
    End If
GNLSKCleanup:
    If fGotNLSKey Then
        GetNLSKey = strNLSKey
    End If
End Function
 
Private Sub Class_Initialize()
    FileName = vbNullString
End Sub

Ответить