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

supergreenbean 2004-04-08 02:18:09
'-------------- 模块文件 ----------------
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 Long

Public g_FileVersionInfoEntryNames(12) As String

Public Const FLAG_FVIENS_INITIALIZED As String = "999"

Public Enum eFileVersionInfoEntryNames
efviComments = 0
efviInternalName
efviProductName
efviCompanyName
efviLegalCopyright
efviProductVersion
efviFileDescription
efviLegalTrademarks
efviPrivateBuild
efviFileVersion
efviOriginalFilename
efviSpecialBuild
efviInitializedFlag
End Enum

Private 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 Function

Private 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 Function

Public 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(efviLegalTrademarks) = "LegalTrademarks" '合法商标
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 Sub

Private 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
...全文
199 5 打赏 收藏 转发到动态 举报
写回复
用AI写文章
5 条回复
切换为时间正序
请发表友善的回复…
发表回复
boyzhang 2004-04-30
  • 打赏
  • 举报
回复
Hao
boyzhang 2004-04-30
  • 打赏
  • 举报
回复
Hao
yinweihong 2004-04-08
  • 打赏
  • 举报
回复
UP
  • 打赏
  • 举报
回复
好东东!
谢先了


up
lihonggen0 2004-04-08
  • 打赏
  • 举报
回复
'**************************************
'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

7,759

社区成员

发帖
与我相关
我的任务
社区描述
VB 基础类
社区管理员
  • VB基础类社区
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧