' Pour récupérer des infos sur les fichiers
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 GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
Public Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" (pBlock As Any, ByVal lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
Public Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersion As Long
dwFileVersionMS As Long
dwFileVersionLS As Long
dwProductVersionMS As Long
dwProductVersionLS As Long
dwFileFlagsMask As Long
dwFileFlags As Long
dwFileOS As Long
dwFileType As Long
dwFileSubtype As Long
dwFileDateMS As Long
dwFileDateLS As Long
End Type
' Le type FileVersionInfos
Public Type FileVersionInfos
FileVersion As String
FileDescription As String
CompanyName As String
InternalName As String
Copyright As String
OriginalFileName As String
ProductName As String
ProductVersion As String
End Type
'---------------------------------------------------------------------------------------
' Procedure : GetFileVersionInfos
' DateTime : 28/12/2006 22:13
' Author : Vb System Library
' Purpose : Récupérer une information sur un fichier
' Params : sFileName : Chemin d'accès au fichier
' Renvoie un type FileVersionInfos
'---------------------------------------------------------------------------------------
Public Function GetFileVersionInfos(ByVal sFileName As String) As FileVersionInfos
Dim Vffi As VS_FIXEDFILEINFO ' version info structure
Dim Buffer() As Byte ' buffer for info ressource
Dim pData As Long ' pointer to info data
Dim lDataLen As Long ' length of info pointed at by pData
Dim cpl(0 To 3) As Byte ' buffer for code page & language
Dim cplstr As String ' 8-digit hex string of cpl
Dim strVersionInfo As String
' Prépare la structure
GetFileVersionInfos.CompanyName = ""
GetFileVersionInfos.Copyright = ""
GetFileVersionInfos.FileDescription = ""
GetFileVersionInfos.FileVersion = ""
GetFileVersionInfos.InternalName = ""
GetFileVersionInfos.OriginalFileName = ""
GetFileVersionInfos.ProductName = ""
GetFileVersionInfos.ProductVersion = ""
' Contrôle si le fichier contient des informations récupérables
lDataLen = GetFileVersionInfoSize(sFileName, pData)
If lDataLen = 0 Then
Exit Function
End If
ReDim Buffer(0 To lDataLen - 1) As Byte
' Get the version information resource.
If GetFileVersionInfo(sFileName, 0, lDataLen, Buffer(0)) <> 0 Then
' Get a pointer to a structure that holds a bunch of data.
If VerQueryValue(Buffer(0), "\", pData, lDataLen) <> 0 Then
' Copy that structure into the one we can access.
MoveMemory Vffi, ByVal pData, lDataLen
' ---------------------------------------
' Récupération de la version du fichier
GetFileVersionInfos.FileVersion = Trim(Str(HIWORD(Vffi.dwFileVersionMS))) & "." & _
Trim(Str(LOWORD(Vffi.dwFileVersionMS))) & "." & _
Trim(Str(HIWORD(Vffi.dwFileVersionLS))) & "." & _
Trim(Str(LOWORD(Vffi.dwFileVersionLS)))
' Récupération du code page et du langage
If VerQueryValue(Buffer(0), "\VarFileInfo\Translation", pData, lDataLen) <> 0 Then
' Copy that information into the byte array.
MoveMemory cpl(0), ByVal pData, 4
' Convert those four bytes into a 8-digit hexadecimal string.
cplstr = FixedHex(cpl(1), 2) & FixedHex(cpl(0), 2) & FixedHex(cpl(3), 2) & FixedHex(cpl(2), 2)
' cplstr contient maintenant le code page et le langage
' ---------------------------------------
' Récupération des autres infos
strVersionInfo = "CompanyName"
If VerQueryValue(Buffer(0), "\StringFileInfo\" & cplstr & "\" & strVersionInfo, pData, lDataLen) <> 0 Then
If lDataLen > 0 Then lDataLen = lDataLen - 1
GetFileVersionInfos.CompanyName = Space(lDataLen)
lstrcpy GetFileVersionInfos.CompanyName, pData
End If
strVersionInfo = "FileDescription"
If VerQueryValue(Buffer(0), "\StringFileInfo\" & cplstr & "\" & strVersionInfo, pData, lDataLen) <> 0 Then
If lDataLen > 0 Then lDataLen = lDataLen - 1
GetFileVersionInfos.FileDescription = Space(lDataLen)
lstrcpy GetFileVersionInfos.FileDescription, pData
End If
strVersionInfo = "FileVersion"
If VerQueryValue(Buffer(0), "\StringFileInfo\" & cplstr & "\" & strVersionInfo, pData, lDataLen) <> 0 Then
If lDataLen > 0 Then lDataLen = lDataLen - 1
GetFileVersionInfos.FileVersion = Space(lDataLen)
lstrcpy GetFileVersionInfos.FileVersion, pData
End If
strVersionInfo = "InternalName"
If VerQueryValue(Buffer(0), "\StringFileInfo\" & cplstr & "\" & strVersionInfo, pData, lDataLen) <> 0 Then
If lDataLen > 0 Then lDataLen = lDataLen - 1
GetFileVersionInfos.InternalName = Space(lDataLen)
lstrcpy GetFileVersionInfos.InternalName, pData
End If
strVersionInfo = "LegalCopyright"
If VerQueryValue(Buffer(0), "\StringFileInfo\" & cplstr & "\" & strVersionInfo, pData, lDataLen) <> 0 Then
If lDataLen > 0 Then lDataLen = lDataLen - 1
GetFileVersionInfos.Copyright = Space(lDataLen)
lstrcpy GetFileVersionInfos.Copyright, pData
End If
strVersionInfo = "OriginalFileName"
If VerQueryValue(Buffer(0), "\StringFileInfo\" & cplstr & "\" & strVersionInfo, pData, lDataLen) <> 0 Then
If lDataLen > 0 Then lDataLen = lDataLen - 1
GetFileVersionInfos.OriginalFileName = Space(lDataLen)
lstrcpy GetFileVersionInfos.OriginalFileName, pData
End If
strVersionInfo = "ProductName"
If VerQueryValue(Buffer(0), "\StringFileInfo\" & cplstr & "\" & strVersionInfo, pData, lDataLen) <> 0 Then
If lDataLen > 0 Then lDataLen = lDataLen - 1
GetFileVersionInfos.ProductName = Space$(lDataLen)
lstrcpy GetFileVersionInfos.ProductName, pData
End If
strVersionInfo = "ProductVersion"
If VerQueryValue(Buffer(0), "\StringFileInfo\" & cplstr & "\" & strVersionInfo, pData, lDataLen) <> 0 Then
If lDataLen > 0 Then lDataLen = lDataLen - 1
GetFileVersionInfos.ProductVersion = Space(lDataLen)
lstrcpy GetFileVersionInfos.ProductVersion, pData
End If
End If
End If
End If
End Function
' Creation d'une chaine Hexadecimale pour représenter un nombre
Private Function FixedHex(ByVal hexval As Long, ByVal nDigits As Long) As String
FixedHex = Right("00000000" & Hex(hexval), nDigits)
End Function
Private Function HIWORD(ByVal dwValue As Long) As Long
Dim hexstr As String
hexstr = Right("00000000" & Hex(dwValue), 8)
HIWORD = CLng("&H" & Left(hexstr, 4))
End Function
Private Function LOWORD(ByVal dwValue As Long) As Long
Dim hexstr As String
hexstr = Right("00000000" & Hex(dwValue), 8)
LOWORD = CLng("&H" & Right(hexstr, 4))
End Function
28/12/2006 : Changement de la fonction
Le 30/12/2006 par MadMatt : Optimisation
Le 11/04/2007 par MadMatt : Résolution dun bug
Le 21/04/2007 par MadMatt : Le code était coupé
Seul les admins et l'auteur du code lui même peuvent modifier ce code.