实用代码：获取文件版本信息

Question

'-------------- 模块文件 ----------------
Option Explicit
'本模块名称
Private Const THIS_MODULE_NAME As String = "Module1"Public Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Public 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
Public Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" (ByVal pBlock As Long, ByVal lpSubBlock As String, lplpBuffer As Long, puLen As Long) As LongPublic g_FileVersionInfoEntryNames(12) As StringPublic Const FLAG_FVIENS_INITIALIZED As String = "999"Public Enum eFileVersionInfoEntryNames
    efviComments = 0
    efviInternalName
    efviProductName
    efviCompanyName
    efviLegalCopyright
    efviProductVersion
    efviFileDescription
    efviLegalTrades
    efviPrivateBuild
    efviFileVersion
    efviOriginalFilename
    efviSpecialBuild
    efviInitializedFlag
End EnumPrivate Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Public Function GetVersionInfo(ByVal sFileName As String, ByVal lEntryName As eFileVersionInfoEntryNames) As String
    On Error GoTo Error_Handler
    Dim i As Long
    Dim lVersionSize As Long
    Dim pBlock() As Byte, SubBlock As String
    Dim lpTranslate As Long, bTranslate() As Byte
    Dim lSizeOflpTranslate As Long
    Dim lplpBuffer() As Byte, puLen As Long, lpBuffer As Long
    
    lVersionSize = GetFileVersionInfoSize(sFileName, 0&)
    If lVersionSize <= 0 Then Exit Function
    
    Call InitFileVersionInfoNames
    
    ReDim pBlock(lVersionSize - 1)
    Call GetFileVersionInfo(sFileName, 0&, lVersionSize, pBlock(0))
    
    VerQueryValue VarPtr(pBlock(0)), "\\VarFileInfo\\Translation", lpTranslate, lSizeOflpTranslate
    ReDim bTranslate(lSizeOflpTranslate - 1)
    CopyMemory bTranslate(0), ByVal lpTranslate, lSizeOflpTranslate
    
    For i = 1 To lSizeOflpTranslate / (UBound(bTranslate) + 1)
        SubBlock = "\\StringFileInfo\\"
        SubBlock = SubBlock & Byte2Hex(bTranslate(), 0, 1, True)
        SubBlock = SubBlock & Byte2Hex(bTranslate(), 2, 3, True)
        SubBlock = SubBlock & "\\" & g_FileVersionInfoEntryNames(lEntryName)
    
        VerQueryValue VarPtr(pBlock(0)), SubBlock, lpBuffer, puLen
        If lpBuffer <> 0 And puLen <> 0 Then
            ReDim lplpBuffer(puLen - 1)
            CopyMemory lplpBuffer(0), ByVal lpBuffer, puLen
            ReDim Preserve lplpBuffer(InStrB(lplpBuffer, ChrB(0)) - 2)
            GetVersionInfo = StrConv(lplpBuffer, vbUnicode)
        End If
    Next    Exit Function
Error_Handler:
    '自定义错误处理    '调用默认错误处理函数
    'Call DefaultErrorHandler(THIS_MODULE_NAME)
End FunctionPrivate Function Byte2Hex(bArray() As Byte, Optional ByVal lStart As Long = 0, Optional ByVal lEnd As Long = -1, Optional fReversed As Boolean = False) As String
    Dim i As Long
    lStart = IIf(lStart < 0, 0, lStart)
    lEnd = IIf(lEnd < 0, UBound(bArray), lEnd)
    
    If fReversed Then
        For i = lEnd To lStart Step -1
            Byte2Hex = Byte2Hex & Right$("00" & Hex(bArray(i)), 2)
        Next
    Else
        For i = lStart To lEnd
            Byte2Hex = Byte2Hex & Right$("00" & Hex(bArray(i)), 2)
        Next
    End If
End FunctionPublic Sub InitFileVersionInfoNames()
    If g_FileVersionInfoEntryNames(12) = FLAG_FVIENS_INITIALIZED Then Exit Sub
    g_FileVersionInfoEntryNames(efviComments) = "Comments"  '注释
    g_FileVersionInfoEntryNames(efviCompanyName) = "CompanyName"  '公司名
    g_FileVersionInfoEntryNames(efviProductName) = "ProductName"  '产品名
    g_FileVersionInfoEntryNames(efviProductVersion) = "ProductVersion"  '产品版本
    g_FileVersionInfoEntryNames(efviInternalName) = "InternalName"  '内部名称
    g_FileVersionInfoEntryNames(efviFileDescription) = "FileDescription"  '文件描述
    g_FileVersionInfoEntryNames(efviFileVersion) = "FileVersion"  '文件版本
    g_FileVersionInfoEntryNames(efviOriginalFilename) = "OriginalFilename"  '原始文件名
    g_FileVersionInfoEntryNames(efviSpecialBuild) = "SpecialBuild"  '特殊编译号
    g_FileVersionInfoEntryNames(efviPrivateBuild) = "PrivateBuild"  '私有编译号
    g_FileVersionInfoEntryNames(efviLegalCopyright) = "LegalCopyright"  '合法版权
    g_FileVersionInfoEntryNames(efviLegalTrades) = "LegalTrades"  '合法商标
    g_FileVersionInfoEntryNames(efviInitializedFlag) = FLAG_FVIENS_INITIALIZED   '是否已经初始化标记
End Sub'-------------- 窗体文件 ----------------
Option Explicit
'本模块名称
Private Const THIS_MODULE_NAME As String = "Form1"Private Sub Form_Initialize()
    'Call InitExceptionHandler
End SubPrivate Sub Form_Load()
    Dim i As Long
    Call InitFileVersionInfoNames
    For i = 0 To efviInitializedFlag - 1
        Debug.Print g_FileVersionInfoEntryNames(i); ":"; GetVersionInfo("c:\windows\notepad.exe", i)
    Next
End Sub

Answer 1

'**************************************
'Windows API/Global Declarations for :Ge
'     t Version Number for EXE, DLL or OCX fil
'     es
'**************************************
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
Private Type FILEINFO
    CompanyName As String
    FileDescription As String
    FileVersion As String
    InternalName As String
    LegalCopyright As String
    OriginalFileName As String
    ProductName As String
    ProductVersion As String
    End Type
Private Enum VerisonReturnValue
    eOK = 1
    eNoVersion = 2
End Enum
'**************************************
' Name: Get Version Number for EXE, DLL
'     or OCX files
' Description:This function will retriev
'     e the version number, product name, orig
'     inal program name (like if you right cli
'     ck on the EXE file and select properties
'     , then select Version tab, it shows you
'     all that information) etc
' By: Serge
'
' Returns:FileInfo structure
'
' Assumes:Label (named Label1 and make i
'     t wide enough, also increase the height
'     of the label to have size of the form),
'     Common Dilaog Box (CommonDialog1) and a
'     Command Button (Command1)
'
'This code is copyrighted and has' limited warranties.Please see http://w
'     ww.Planet-Source-Code.com/vb/scripts/Sho
'     wCode.asp?txtCodeId=4976&lngWId=1'for details.'**************************************Private 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)
    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