ExcelVBAで、実行ファイルのバージョンを取得する必要があったので書いてみたコード。
x64版にもさりげなく対応させている。
x64版だと、APIの定義でPtrSafeキーワードを指定する必要があったり、ポインタサイズが64bitになることにより、特にハンドラの型をLongからLongPtrに変更する必要がある。
Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" ( _
ByVal lptstrFilename As String, _
ByRef lpdwHandle As LongPtr) As Long
Private Declare PtrSafe Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" ( _
ByVal lptstrFilename As String, _
ByVal dwHandle As LongPtr, _
ByVal dwLen As Long, _
ByRef lpData As Any) As Long
Private Declare PtrSafe Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" ( _
ByRef pBlock As Any, _
ByVal lpSubBlock As String, _
ByRef lplpBuffer As Any, _
ByRef puLen As Long) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
#Else
Private Declare Function GetFileVersionInfoSize Lib "version.dll" Alias "GetFileVersionInfoSizeA" ( _
ByVal lptstrFilename As String, _
ByRef lpdwHandle As Long) As Long
Private Declare Function GetFileVersionInfo Lib "version.dll" Alias "GetFileVersionInfoA" ( _
ByVal lptstrFilename As String, _
ByVal dwHandle As Long, _
ByVal dwLen As Long, _
ByRef lpData As Any) As Long
Private Declare Function VerQueryValue Lib "version.dll" Alias "VerQueryValueA" ( _
ByRef pBlock As Any, _
ByVal lpSubBlock As String, _
ByRef lplpBuffer As Any, _
ByRef puLen As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal Length As Long)
#End If
Private Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersionl As Integer
dwStrucVersionh As Integer
dwFileVersionMSl As Integer
dwFileVersionMSh As Integer
dwFileVersionLSl As Integer
dwFileVersionLSh As Integer
dwProductVersionMSl As Integer
dwProductVersionMSh As Integer
dwProductVersionLSl As Integer
dwProductVersionLSh As Integer
dwFileFlagsMask As Long
dwFileFlags As Long
dwFileOS As Long
dwFileType As Long
dwFileSubtype As Long
dwFileDateMS As Long
dwFileDateLS As Long
End Type
Private Type FILEINFOOUT
FileVersion As String
ProductVersion As String
End Type
Public Sub GetVersion(ByVal path As String)
#If VBA7 And Win64 Then
Dim handle As LongPtr
Dim verPointer As LongPtr
#Else
Dim handle As Long
Dim verPointer As Long
#End If
Dim size As Long
Dim verBufLen As Long
Dim fInfoOut As FILEINFOOUT
Dim fileInfo As VS_FIXEDFILEINFO
Dim buffer() As Byte
size = GetFileVersionInfoSize(path, handle)
If size = 0 Then
GoTo ErrorHandler
End If
ReDim buffer(size)
If Not CBool(GetFileVersionInfo(path, 0&, size, buffer(0))) Then
GoTo ErrorHandler
End If
If Not CBool(VerQueryValue(buffer(0), "\", verPointer, verBufLen)) Then
GoTo ErrorHandler
End If
Call CopyMemory(fileInfo, ByVal verPointer, Len(fileInfo))
With fileInfo
fInfoOut.FileVersion = _
Format$(.dwFileVersionMSh) & "." & _
Format$(.dwFileVersionMSl) & "." & _
Format$(.dwFileVersionLSh) & "." & _
Format$(.dwFileVersionLSl)
fInfoOut.ProductVersion = _
Format$(.dwProductVersionMSh) & "." & _
Format$(.dwProductVersionMSl) & "." & _
Format$(.dwProductVersionLSh) & "." & _
Format$(.dwProductVersionLSl)
End With
Debug.Print "File Version: " & fInfoOut.FileVersion
Debug.Print "Product Version: " & fInfoOut.ProductVersion
Exit Sub
ErrorHandler:
Debug.Print "Error!"
End Sub