Qiita Teams that are logged in
You are not logged in to any team

Log in to Qiita Team
Community
OrganizationAdvent CalendarQiitadon (β)
Service
Qiita JobsQiita ZineQiita Blog
Help us understand the problem. What is going on with this article?

ExcelVBAで実行ファイルやdllのバージョンを取得する

More than 5 years have passed since last update.

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
shela
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away