| |
или любого файла, если, конечно, вы сможете
получить описание.
Тестирование данного примера я провел на
нескольких exe-файлах, некоторых системных
библиотеках и даже обычных текстовых файлах. Для
простоты проверки примера добавьте на форму
элемент TextBox и элемент CommandButton.
Естественно, в текстовое окно вы должны
вставлять полный путь к проверяемому файлу.
Но вот где хранятся эти описания, осталось для
меня загадкой. Поиск в реестре ничего не дал...
Вам понадобится дополнительный модуль.
'КОД ФОРМЫ
Private Sub Command1_Click()
MsgBox GetFileDescription("c:\win\system\shell32.dll")
'MsgBox GetFileDescription(Text1.Text)
End Sub
'КОД МОДУЛЯ
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
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
|
|