Author  

Language  

Operating Systems  

'Declarations:
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

'Functions:

Public Function StringFromBuffer(buffer As String) As String
    Dim nPos As Long

    nPos = InStr(buffer, vbNullChar)
    If nPos > 0 Then
        StringFromBuffer = Left$(buffer, nPos - 1)
    Else
        StringFromBuffer = buffer
    End If
End Function

Public Function GetFileDescription(ByVal sFile As String) As String
    Dim lVerSize As Long
    Dim lTemp As Long
    Dim lRet As Long
    Dim bInfo() As Byte
    Dim lpBuffer As Long
    Dim sDesc As String
    Dim sKEY As String

    lVerSize = GetFileVersionInfoSize(sFile, lTemp)
    ReDim bInfo(lVerSize)
    If lVerSize > 0 Then
    lRet = GetFileVersionInfo(sFile, lTemp, lVerSize, VarPtr(bInfo(0)))
        If lRet <> 0 Then
            sKEY = GetNLSKey(bInfo)
            lRet = VerQueryValue(VarPtr(bInfo(0)), sKEY & "\FileDescription", lpBuffer, lVerSize)
            If lRet <> 0 Then
                sDesc = Space$(lVerSize)
                lstrcpyn sDesc, lpBuffer, lVerSize
                GetFileDescription = StringFromBuffer(sDesc)
            End If
        End If
    End If
End Function

Public Function GetNLSKey(byteVerData() As Byte) As String
    Static strLANGCP As String
    Dim lpBufPtr As Long
    Dim strNLSKey As String
    Dim fGotNLSKey As Integer
    Dim intOffset As Integer
    Dim lVerSize As Long
    Dim lTmp As Long
    Dim lBufLen As Long
    Dim lLCID As Long
    Dim strTmp As String

    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

Option Explicit

Private Sub Command1_Click()
    MsgBox GetFileDescription("c:\windows\system\shell32.dll")
End Sub