VB6: RÉCUPÉRER SIMPLEMENT LES INFORMATIONS D'UN FICHIER

Signaler
Messages postés
168
Date d'inscription
vendredi 9 janvier 2004
Statut
Membre
Dernière intervention
28 juillet 2009
-
Messages postés
4822
Date d'inscription
lundi 11 novembre 2002
Statut
Membre
Dernière intervention
15 novembre 2016
-
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

Messages postés
4822
Date d'inscription
lundi 11 novembre 2002
Statut
Membre
Dernière intervention
15 novembre 2016
13
Effectivement, parfait comme explication.
A+
Exploreur
Messages postés
550
Date d'inscription
jeudi 12 octobre 2006
Statut
Membre
Dernière intervention
6 juin 2015
4
Excellent !
Messages postés
168
Date d'inscription
vendredi 9 janvier 2004
Statut
Membre
Dernière intervention
28 juillet 2009
1
Pour info, j'utilise le code ci-dessous (glané sur Internet). Peut-être te donnera-t'il des idées...


' -------------------------------------------------
'
' 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