1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
| '*********************
'Sources:
'http://support.microsoft.com/kb/466935/fr
'http://support.microsoft.com/kb/160042/fr
'http://vb.developpez.com/faq/?page=Fichiers#num_version
'
'adapté pour utilisation en VBA Excel
'*********************
Option Explicit
'Renvoie des informations sur la version, pour le fichier spécifié.
'lptstrFilename: adresse du nom de fichier
'dwHandle: handle d'information sur la version
'dwLen: taille du buffer contenant l'information
'lpData: adresse du premier octet du buffer contenant l'information
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
'La fonction GetFileVersionInfoSize détermine si les informations sur la
'version existent. Si c'est le cas, cette fonction retourne la taille du
'buffer contenant l'information et le handle d'information que l'on
'passera à L'API GetFileVersionInfo. Cette dernière permet de récupérer
'les informations sur la version.
'lptstrFilename: adresse du nom de fichier
'lpdwHandle: adresse du handle d'information sur la version
Private Declare Function _
GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" _
(ByVal lptstrFilename As String, lpdwHandle As Long) As Long
'La fonction VerQueryValue retourne la partie d'information sur la version:
'pBlock: adresse du premier octet du buffer contenant l'information
'lpSubBlock: adresse de la partie de l'information qui nous intéresse
'lplpBuffer: adresse du buffer contenant la valeur demandée
'puLen: adresse de la taille du buffer contenant la valeur demandée
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)
'Copie une chaîne de caractères dans une autre
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" _
(ByVal lpString1 As String, ByVal lpString2 As Long) As Long
'Renvoie l'adresse de l'executable auquel le fichier est associé
Public Declare Function FindExecutableA Lib "shell32.dll" (ByVal lpFile As String, _
ByVal lpdirectory As String, ByVal lpResult As String) As Long
Public Const MAX_FILENAME_LEN = 256
Public Function DescriptionAppli(ByVal Cible As String, _
ByVal TypeInfo As String) As String
Dim Buffer As String, Lang_Charset_String As String
Dim Rc As Long, HexNumber As Long, P As Long
Dim strVersionInfo As String, strTemp As String
Dim BufferLen As Long, Dummy As Long
Dim sBuffer() As Byte
Dim ByteBuffer(255) As Byte
strVersionInfo = TypeInfo
'Vérifie si les informations sur la version existent.
BufferLen = GetFileVersionInfoSize(Cible, Dummy)
If BufferLen < 1 Then Exit Function
ReDim sBuffer(BufferLen)
Rc = GetFileVersionInfo(Cible, 0&, BufferLen, sBuffer(0))
If Rc = 0 Then
DescriptionAppli = False
Exit Function
End If
'"\VarFileInfo\Translation" permet de récupérer la langue utilisée et
'le type de caractère:
'Par exemple, on peut récupérer la valeur 040C1200 où 040C identifie la
'langue française et 1200 identifie le jeu de caractères Unicode
'(Les valeurs des identifiants de langue et de jeu de caractères sont
'données dans l'aide WIN SDK 32 HELP pour la structure VERSIONINFO).
Rc = _
VerQueryValue(sBuffer(0), "\VarFileInfo\Translation", P, BufferLen)
If Rc = 0 Then Exit Function
MoveMemory ByteBuffer(0), P, BufferLen
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
Buffer = String(255, 0)
strTemp = "\StringFileInfo\" & Lang_Charset_String & "\" & strVersionInfo
Rc = VerQueryValue(sBuffer(0), strTemp, P, BufferLen)
If Rc = 0 Then Exit Function
lstrcpy Buffer, P
Buffer = Mid$(Buffer, 1, InStr(Buffer, Chr(0)) - 1)
DescriptionAppli = Buffer
End Function
'Permet de retrouver l'executable du fichier spécifié.
Function FindExecutable(s As String) As String
Dim i As Integer
Dim S2 As String
S2 = String(MAX_FILENAME_LEN, 32) & Chr$(0)
i = FindExecutableA(s & Chr$(0), vbNullString, S2)
If i > 32 Then
FindExecutable = Left$(S2, InStr(S2, Chr$(0)) - 1)
Else
FindExecutable = ""
End If
End Function
Sub AfficherInformationsApplication()
Dim Resultat As String, MonAppli As String, LeFichier As String
Dim X As Variant
Dim Tableau As Variant
Dim i As Byte
'Définit les types d'informatins à récupérer
Tableau = Array("Name", "comments ", "CompanyName", "FileDescription", _
"FileVersion", "InternalName", "LegalCopyright", "legalTrademarks", _
"privateBuild", "OriginalFileName", "ProductName", _
"productVersionNum", "ProductVersion")
'Affiche un boîte de dialogue pour sélectionner un fichier sur le PC
X = Application.GetOpenFilename
'On sort si aucun fichier n'est sélectionné ou si vous avez appuyé
'sur le bouton "Annuler".
If X = False Then Exit Sub
LeFichier = X
'Recherche l'executable associé au fichier sélectionné
MonAppli = FindExecutable(LeFichier)
'boucle sur les infos à récupérer
For i = 0 To 12
Resultat = Resultat & Tableau(i) & " : " & _
DescriptionAppli(MonAppli, Tableau(i)) & vbLf
Next i
'Affiche le resultat de la procedure
MsgBox Resultat, , "Informations : " & MonAppli
End Sub |
[Sources][FAQ VBA Excel] Informations sur les applications
Répondre avec citation
Partager