File info
Description
Voici une ptit module qui recupere presque toutes les infos d'un fichier.
Utilisation:
Dim F as FileInfo
F = GetFileInfo(Chemin_Fichier)
les info renvoyees sont:
FullPathName
FileName
Extension
ExistFile
FileSize
CompanyName
FileDescription
FileVersion
InternalName
LegalCopyright
OriginalFileName
ProductName
ProductVersion
CreationTime
LastAccessTime
LastWriteTime
FileAttribute
Utilisation:
Dim F as FileInfo
F = GetFileInfo(Chemin_Fichier)
les info renvoyees sont:
FullPathName
FileName
Extension
ExistFile
FileSize
CompanyName
FileDescription
FileVersion
InternalName
LegalCopyright
OriginalFileName
ProductName
ProductVersion
CreationTime
LastAccessTime
LastWriteTime
FileAttribute
Source / Exemple :
Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
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
Private Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal lptstrFilename As String, lpdwHandle As Long) As Long
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 Function FileTimeToLocalFileTime Lib "kernel32" (lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal Source As Long, ByVal Length As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Public Type FileInfo
CompanyName As String
FileDescription As String
FileVersion As String
ExistFile As Boolean
InternalName As String
LegalCopyright As String
OriginalFileName As String
ProductName As String
ProductVersion As String
FileName As String
FullPathName As String
Extension As String
FileSize As String
CreationTime As String
LastAccessTime As String
LastWriteTime As String
FileAttribute As String
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private sbuffer() As Byte
Private bufferlen As Long
Private buffer As String
Private Lang_Charset As String
Private rc As Long
Private VerPointer As Long
Public Function GetFileInfo(ByVal PathFileName As String) As FileInfo
Dim Dummy As Long
Dim ByteBuffer(255) As Byte
Dim HexNumber As Long
Dim pos As Integer
Dim mem As String
Dim lenmem As Long
Dim WFD As WIN32_FIND_DATA
GetFileInfo.FullPathName = PathFileName
pos = InStrRev(PathFileName, "\")
If pos > 0 Then GetFileInfo.FileName = Right(PathFileName, Len(PathFileName) - pos)
pos = InStrRev(PathFileName, ".")
If pos > 0 Then GetFileInfo.Extension = Right(PathFileName, Len(PathFileName) - pos)
GetFileInfo.ExistFile = FileExist(PathFileName)
If GetFileInfo.ExistFile = False Then Exit Function
WFD = GetWFD(PathFileName)
GetFileInfo.FileAttribute = GetStrAtt(WFD.dwFileAttributes)
GetFileInfo.FileSize = Format$(WFD.nFileSizeHigh + WFD.nFileSizeLow, "#,###,###")
GetFileInfo.CreationTime = StrFileTime(WFD.ftCreationTime)
GetFileInfo.LastAccessTime = StrFileTime(WFD.ftLastAccessTime)
GetFileInfo.LastWriteTime = StrFileTime(WFD.ftLastWriteTime)
bufferlen = GetFileVersionInfoSize(PathFileName, Dummy)
If bufferlen < 1 Then Exit Function
ReDim sbuffer(bufferlen)
If GetFileVersionInfo(PathFileName, 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
GetFileInfo.CompanyName = SplitInfo("CompanyName")
GetFileInfo.FileDescription = SplitInfo("FileDescription")
GetFileInfo.FileVersion = SplitInfo("FileVersion")
GetFileInfo.InternalName = SplitInfo("InternalName")
GetFileInfo.LegalCopyright = SplitInfo("LegalCopyright")
GetFileInfo.OriginalFileName = SplitInfo("OriginalFileName")
GetFileInfo.ProductName = SplitInfo("ProductName")
GetFileInfo.ProductVersion = SplitInfo("ProductVersion")
End Function
Public Function FileExist(ByVal File As String) As Boolean
FileExist = CBool(PathFileExists(File))
End Function
Private Function GetWFD(ByVal PathFile As String) As WIN32_FIND_DATA
FindClose FindFirstFile(PathFile, GetWFD)
End Function
Private Function SplitInfo(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
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
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
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.