GetVersion

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 Sub MoveMemory Lib "kernel32" Alias _
"RtlMoveMemory" (dest As Any, ByVal Source As Long, _
ByVal Length As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias _
"lstrcpyA" (ByVal lpString1 As String, _
ByVal lpString2 As Long) As Long
Public Type FILEINFO
CompanyName As String
FileDescription As String
FileVersion As String
InternalNameAs String
LegalCopyright As String
OriginalFileName As String
ProductName As String
ProductVersion As String
End Type
Public Enum VerisonReturnValue
eOK = 1
eNoVersion = 2
End Enum
Public Function GetFileVersionInformation(ByRef pstrFieName _
As String, ByRef tFileInfo As FILEINFO) _
As VerisonReturnValue

Dim lBufferLen As Long, lDummy As Long
Dim sBuffer() As Byte
Dim lVerPointer As Long
Dim lRet As Long
Dim Lang_Charset_String As String
Dim HexNumber As Long
Dim i As Integer
Dim strTemp As String
'Clear the Buffer tFileInfo

tFileInfo.CompanyName = ""
tFileInfo.FileDescription = ""
tFileInfo.FileVersion = ""
tFileInfo.InternalName = ""
tFileInfo.LegalCopyright = ""
tFileInfo.OriginalFileName = ""
tFileInfo.ProductName = ""
tFileInfo.ProductVersion = ""
lBufferLen = GetFileVersionInfoSize(pstrFieName, lDummy)
If lBufferLen < 1 Then
GetFileVersionInformation = eNoVersion
Exit Function
End If
ReDim sBuffer(lBufferLen)
lRet = GetFileVersionInfo(pstrFieName, 0&, lBufferLen, _
sBuffer(0))
If lRet = 0 Then
GetFileVersionInformation = eNoVersion
Exit Function
End If
lRet = VerQueryValue(sBuffer(0), "\VarFileInfo\Translation", _
lVerPointer, lBufferLen)
If lRet = 0 Then
GetFileVersionInformation = eNoVersion
Exit Function
End If
Dim bytebuffer(255) As Byte
MoveMemory bytebuffer(0), lVerPointer, lBufferLen
HexNumber = bytebuffer(2) + bytebuffer(3) * &H100 + _
bytebuffer(0) * &H10000 + bytebuffer(1) * _
&H1000000

Lang_Charset_String = Hex(HexNumber)

'Pull it all apart:

'04------= SUBLANG_ENGLISH_USA

'--09----= LANG_ENGLISH

' ----04E4 = 1252 = Codepage for Windows:Multilingual

Do While Len(Lang_Charset_String) < 8
Lang_Charset_String = "0" & Lang_Charset_String
Loop
Dim strVersionInfo(7) As String
strVersionInfo(0) = "CompanyName"
strVersionInfo(1) = "FileDescription"
strVersionInfo(2) = "FileVersion"
strVersionInfo(3) = "InternalName"
strVersionInfo(4) = "LegalCopyright"
strVersionInfo(5) = "OriginalFileName"
strVersionInfo(6) = "ProductName"
strVersionInfo(7) = "ProductVersion"
Dim buffer As String
For i = 0 To 7
buffer = String(255, 0)
strTemp = "\StringFileInfo\" & Lang_Charset_String _
& "\" & strVersionInfo(i)
lRet = VerQueryValue(sBuffer(0), strTemp, _
lVerPointer, lBufferLen)
If lRet = 0 Then
GetFileVersionInformation = eNoVersion
Exit Function
End If
lstrcpy buffer, lVerPointer
buffer = Mid$(buffer, 1, InStr(buffer, vbNullChar) - 1)
Select Case i
Case 0
tFileInfo.CompanyName = buffer
Case 1
tFileInfo.FileDescription = buffer
Case 2
tFileInfo.FileVersion = buffer
Case 3
tFileInfo.InternalName = buffer
Case 4
tFileInfo.LegalCopyright = buffer
Case 5
tFileInfo.OriginalFileName = buffer
Case 6
tFileInfo.ProductName = buffer
Case 7
tFileInfo.ProductVersion = buffer
End Select
Next i
GetFileVersionInformation = eOK
End Function

Private Sub Command1_Click()
Dim strFile As String
Dim udtFileInfo As FILEINFO
On Error Resume Next
With CommonDialog1
.Filter = "All Files (*.*)|*.*"
.ShowOpen
strFile = .FileName
If Err.Number = cdlCancel Or strFile = "" Then Exit Sub
End With
If GetFileVersionInformation(strFile, udtFileInfo) = eNoVersion Then
MsgBox "No version available For this file", vbInformation
Exit Sub
End If
Label1 = "Company Name: " & _
udtFileInfo.CompanyName & _vbCrLf
Label1 = Label1 & _
"File Description:" & udtFileInfo.FileDescription & vbCrLf
Label1 = Label1 & _
"File Version:" & udtFileInfo.FileVersion & vbCrLf
Label1 = Label1 & _
"Internal Name: " & udtFileInfo.InternalName & vbCrLf
Label1 = Label1 & _
"Legal Copyright: " & udtFileInfo.LegalCopyright & vbCrLf
Label1 = Label1 & _
"Original FileName:" & udtFileInfo.OriginalFileName & vbCrLf
Label1 = Label1 & _
"Product Name:" & udtFileInfo.ProductName & vbCrLf
Label1 = Label1 & _
"Product Version: " & udtFileInfo.ProductVersion & vbCrLf
End Sub

Richiede:
Una lalel(Label1) con la proprieta autoSize impostata
Una Common Dialog Box (CommonDialog1)
Un Command Button (Command1)