Option Compare Database
Option Explicit
Private Type FileInfo
wLength As Integer
wValueLength As Integer
szKey As String * 16
dwSignature As Long
dwStrucVersion As Long
dwFileVersionMS As Long
dwFileVersionLS As Long
End Type
Private Declare Function GetFileVersionInfo& Lib "Version" _
Alias "GetFileVersionInfoA" _
(ByVal FileName$, ByVal dwHandle&, ByVal cbBuff&, ByVal lpvData$)
Private Declare Function GetFileVersionInfoSize& Lib "Version" _
Alias "GetFileVersionInfoSizeA" _
(ByVal FileName$, dwHandle&)
Private Declare Sub hmemcpy Lib "kernel32" _
Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbBytes&)
Dim giMainFolderStrLen As Integer
Const gcMaxSubfolders = 50
Function LOWORD(X As Long) As Integer
On Error Resume Next
LOWORD = X And &HFFFF&
'Low 16 bits contain Minor revision number.
End Function
Function HIWORD(X As Long) As Integer
On Error Resume Next
HIWORD = X \ &HFFFF&
'High 16 bits contain Major revision number.
End Function
Sub ReadFileInfos(strDatabaseName As String, strTblName As String, _
strFolderName As String)
On Error Resume Next
Dim db As Database
Dim rs As Recordset
Dim td As TableDef
Dim fld As Field
Dim idx As Index, fldIndex As Field
Dim fFormat As Property
DoCmd.Hourglass True
giMainFolderStrLen = Len(strFolderName)
If strDatabaseName = "[Current]" Then
Set db = CurrentDb
Else
If Dir(strDatabaseName) = "" Then
Set db = DBEngine.CreateDatabase(strDatabaseName, dbLangGeneral)
Else
Set db = DBEngine.OpenDatabase(strDatabaseName)
End If
End If
Set td = db.CreateTableDef(strTblName)
Set fld = td.CreateField("ID", dbLong)
fld.Attributes = fld.Attributes + dbAutoIncrField
td.Fields.Append fld
Set fld = td.CreateField("FilePath", dbText, 255)
td.Fields.Append fld
Set fld = td.CreateField("FileName", dbText, 255)
td.Fields.Append fld
Set fld = td.CreateField("Date", dbDate)
td.Fields.Append fld
Set fld = td.CreateField("People", dbText, 50)
td.Fields.Append fld
Set fld = td.CreateField("Division", dbText, 50)
td.Fields.Append fld
Set fld = td.CreateField("Event", dbText, 50)
td.Fields.Append fld
Set fld = td.CreateField("Location", dbText, 50)
td.Fields.Append fld
Set fld = td.CreateField("Use", dbText, 50)
td.Fields.Append fld
Set fld = td.CreateField("Dimensions", dbText, 50)
td.Fields.Append fld
Set fld = td.CreateField("Copyright", dbBoolean)
td.Fields.Append fld
Set fld = td.CreateField("Copyright holder", dbText, 50)
td.Fields.Append fld
Set fld = td.CreateField("Description", dbMemo, 50)
td.Fields.Append fld
Set fld = td.CreateField("FileLength", dbDouble)
td.Fields.Append fld
Set idx = td.CreateIndex("PrimaryKey")
Set fldIndex = idx.CreateField("ID", dbLong)
idx.Fields.Append fldIndex
idx.Primary = True
td.Indexes.Append idx
db.TableDefs.Append td
db.TableDefs.Refresh
Set rs = db.OpenRecordset(strTblName)
ReadFolderInfo rs, strFolderName & "\"
rs.Close
If strDatabaseName <> "[Current]" Then
db.Close
Else
Set db = Nothing
End If
DoCmd.Hourglass False
End Sub
Sub ReadFolderInfo(rs As Recordset, strFolderName As String)
Dim arrFoldernames(gcMaxSubfolders)
Dim FileName As String
Dim X As FileInfo
Dim FileVer As String
Dim dwHandle&, BufSize&, lpvData$, r&
Dim iLoop As Long, iLoop2 As Long
Dim Types As String
FileName = Dir(strFolderName, vbdirectory)
iLoop = -1
While FileName <> "" And iLoop < gcMaxSubfolders
If FileName <> "." And FileName <> ".." And FileName <> "" Then
If (GetAttr(strFolderName & FileName) And vbdirectory) = vbdirectory Then
iLoop = iLoop + 1
arrFoldernames(iLoop) = FileName
Else
Types = UCase(Right(FileName, 3))
Select Case Types
Case "xls", "JPG", "PCD", "PCX", "WMF", "EMF", "DIB", "BMP", "ICO", "EPS", "PCT", "DXF", "CGM", "CDR", "TGA", "GIF", "PNG", "WPG", "DRW"
FileVer = ""
BufSize& = GetFileVersionInfoSize(strFolderName & FileName, dwHandle&)
If BufSize& = 0 Then
FileVer = "no Version"
Else
lpvData$ = Space$(BufSize&)
r& = GetFileVersionInfo(strFolderName & FileName, dwHandle&, BufSize&, lpvData$)
hmemcpy X, ByVal lpvData$, Len(X)
FileVer = Trim$(Str$(HIWORD(X.dwFileVersionMS))) + "."
FileVer = FileVer + Trim$(Str$(LOWORD(X.dwFileVersionMS))) + "."
FileVer = FileVer + Trim$(Str$(HIWORD(X.dwFileVersionLS))) + "."
FileVer = FileVer + Trim$(Str$(LOWORD(X.dwFileVersionLS)))
End If
rs.AddNew
rs!FilePath = strFolderName
rs!FileName = FileName
rs!FileLength = FileLen(strFolderName & FileName)
rs!Date = FileDateTime(strFolderName & FileName)
rs.Update
Case Else
End Select
End If
End If
FileName = Dir
Wend
For iLoop2 = 0 To iLoop
ReadFolderInfo rs, strFolderName & arrFoldernames(iLoop2) & "\"
Next iLoop2
End Sub
Private Sub FileInfo(iPath$, iFile$)
Dim i As Byte, u As Byte, Item$, Info
With CreateObject("Shell.Application").NameSpace(CStr(iPath))
i = 26
Info = .GetDetailsOf(.ParseName(iFile), i)
Item = .GetDetailsOf(.Items, i)
If Len(Info) And Len(Item) Then
u = u + 1
Cells(u, 1) = .GetDetailsOf(.Items, i)
Cells(u, 2) = Info
End If
End With
End Sub
Sub Test()
Const P$ = "Path of My file name"
Const F$ = "My file name"
Call FileInfo(P, F)
End Sub
