VB6: RÉCUPÉRER SIMPLEMENT LES INFORMATIONS D'UN FICHIER
cavo789
Messages postés
168
Date d'inscription
vendredi 9 janvier 2004
Statut
Membre
Dernière intervention
28 juillet 2009
-
27 déc. 2006 à 09:30
cs_Exploreur Messages postés 4821 Date d'inscription lundi 11 novembre 2002 Statut Membre Dernière intervention 15 novembre 2016 - 29 déc. 2006 à 11:28
cs_Exploreur Messages postés 4821 Date d'inscription lundi 11 novembre 2002 Statut Membre Dernière intervention 15 novembre 2016 - 29 déc. 2006 à 11:28
Cette discussion concerne un article du site. Pour la consulter dans son contexte d'origine, cliquez sur le lien ci-dessous.
https://codes-sources.commentcamarche.net/source/40819-vb6-recuperer-simplement-les-informations-d-un-fichier
https://codes-sources.commentcamarche.net/source/40819-vb6-recuperer-simplement-les-informations-d-un-fichier
29 déc. 2006 à 11:28
A+
Exploreur
27 déc. 2006 à 16:24
27 déc. 2006 à 09:30
' -------------------------------------------------
'
' Used by the GetFileInfo function
'
' -------------------------------------------------
Private Function GetWFD(ByVal PathFile As String) As WIN32_FIND_DATA
FindClose FindFirstFile(PathFile, GetWFD)
End Function
' -------------------------------------------------
'
' Used by the GetFileInfo function
'
' -------------------------------------------------
Private Function GetStrAtt(ByVal att As Long) As String
Dim s As String
If att 128 Then GetStrAtt "N": Exit Function
If att 0 Then GetStrAtt "None": Exit Function
If att >32768 Then att att - 32768: s = "L"
If att >16384 Then att att - 16384: s = s & "E"
If att >8192 Then att att - 8192 ' Not For Index
If att >4096 Then att att - 4096: s = s & "O"
If att >2048 Then att att - 2048: s = s & "C"
If att >1024 Then att att - 1024: s = s & "R-P"
If att >512 Then att att - 512: s = s & "S-F"
If att >256 Then att att - 256: s = s & "T"
If att >32 Then att att - 32: s = s & "A"
If att >16 Then att att - 16: s = s & "D"
If att >4 Then att att - 4: s = s & "S"
If att >2 Then att att - 2: s = s & "H"
If att >1 Then att att - 1: s = s & "R"
If att 0 Then GetStrAtt s Else GetStrAtt = "Erreur d'attribut"
End Function
' -------------------------------------------------
'
' Used by the GetFileInfo function
'
' -------------------------------------------------
Private Function StrFileTime(Htime As FILETIME) As String
Dim SysTime As SYSTEMTIME
Dim LTime As FILETIME
FileTimeToLocalFileTime Htime, LTime
FileTimeToSystemTime LTime, SysTime
StrFileTime = DateSerial(SysTime.wYear, SysTime.wMonth, SysTime.wDay) + TimeSerial(SysTime.wHour, SysTime.wMinute, SysTime.wSecond)
End Function
' -------------------------------------------------
'
' Used by the GetFileInfo function
'
' -------------------------------------------------
Private Function SplitInfo(ByVal StrFilter As String) As String
Dim strtemp As String
buffer = String(255, 0)
strtemp = "\StringFileInfo" & Lang_Charset & "" & StrFilter
If VerQueryValue(sbuffer(0), strtemp, VerPointer, bufferlen) = 0 Then Exit Function
lstrcpy buffer, VerPointer
SplitInfo = Left$(buffer, InStr(buffer, Chr(0)) - 1)
End Function
' -------------------------------------------------
'
' GetFileInfo ask a valid filename and will return his version number, his extension, ...
'
' -------------------------------------------------
Public Function ZGetFileInfo(ByVal sFileName As String) As FileInfo
'http://www.vbfrance.com/codes/FILE-INFO_39252.aspx
Dim Dummy As Long
Dim ByteBuffer(255) As Byte
Dim I As Byte
Dim arrVersion As Variant
Dim HexNumber As Long
Dim pos As Integer
Dim mem As String
Dim lenmem As Long
Dim WFD As WIN32_FIND_DATA
Dim sTemp As String
On Error GoTo ErrHandler
ZGetFileInfo.FullPathName = sFileName
pos = InStrRev(sFileName, "")
If pos > 0 Then ZGetFileInfo.FileName = Right(sFileName, Len(sFileName) - pos)
pos = InStrRev(sFileName, ".")
If pos > 0 Then ZGetFileInfo.Extension = Right(sFileName, Len(sFileName) - pos)
ZGetFileInfo.ExistFile = ZFileExists(sFileName)
If ZGetFileInfo.ExistFile = False Then Exit Function
WFD = GetWFD(sFileName)
ZGetFileInfo.FileAttribute = GetStrAtt(WFD.dwFileAttributes)
ZGetFileInfo.FileSize = Format$(WFD.nFileSizeHigh + WFD.nFileSizeLow, "#,###,###")
ZGetFileInfo.CreationTime = StrFileTime(WFD.ftCreationTime)
ZGetFileInfo.LastAccessTime = StrFileTime(WFD.ftLastAccessTime)
ZGetFileInfo.LastWriteTime = StrFileTime(WFD.ftLastWriteTime)
bufferlen = GetFileVersionInfoSize(sFileName, Dummy)
If bufferlen < 1 Then Exit Function
ReDim sbuffer(bufferlen)
If GetFileVersionInfo(sFileName, 0&, bufferlen, sbuffer(0)) = 0 Then Exit Function
If VerQueryValue(sbuffer(0), "\VarFileInfo\Translation", VerPointer, bufferlen) = 0 Then Exit Function
MoveMemory ByteBuffer(0), VerPointer, bufferlen
HexNumber = ByteBuffer(2) + ByteBuffer(3) * &H100 + ByteBuffer(0) * &H10000 + ByteBuffer(1) * &H1000000
Lang_Charset = Hex(HexNumber)
If Len(Lang_Charset) < 8 Then Lang_Charset = String(8 - (Len(Lang_Charset)), "0") & Lang_Charset
ZGetFileInfo.CompanyName = SplitInfo("CompanyName")
ZGetFileInfo.FileDescription = SplitInfo("FileDescription")
ZGetFileInfo.InternalName = SplitInfo("InternalName")
ZGetFileInfo.LegalCopyright = SplitInfo("LegalCopyright")
ZGetFileInfo.OriginalFileName = SplitInfo("OriginalFileName")
ZGetFileInfo.ProductName = SplitInfo("ProductName")
' Get the file version. Sometimes, the file version can be 2.00.002. The code below will remove preceding
' zeros so 2.00.002 will be transform into 2.0.2
sTemp = SplitInfo("FileVersion")
If (sTemp <> "") And Not (sTemp = vbNullString) Then
arrVersion = Split(sTemp, ".")
sTemp = vbNullString
For I = 0 To UBound(arrVersion)
sTemp = sTemp & CLng(arrVersion(I)) & "."
Next
If Not sTemp = vbNullString Then
ZGetFileInfo.FileVersion = Left(sTemp, Len(sTemp) - 1)
Else
ZGetFileInfo.FileVersion = vbNullString
End If
sTemp = SplitInfo("ProductVersion")
If (sTemp <> "") And Not (sTemp = vbNullString) Then
arrVersion = Split(sTemp, ".")
sTemp = vbNullString
For I = 0 To UBound(arrVersion)
sTemp = sTemp & CLng(arrVersion(I)) & "."
Next
If Not sTemp = vbNullString Then
ZGetFileInfo.ProductVersion = Left(sTemp, Len(sTemp) - 1)
Else
ZGetFileInfo.ProductVersion = vbNullString
End If
Else
ZGetFileInfo.ProductVersion = vbNullString
End If
Else
ZGetFileInfo.FileVersion = vbNullString
ZGetFileInfo.ProductVersion = vbNullString
End If
On Error GoTo 0
Exit Function
ErrHandler:
Msgbox Err.Number & ": " & Err.Description,
On Error GoTo 0
End Function