Dear All, Dear Lisa, Dear Paul, Dear Dr B
Actually, the Shell object is your real best friend. With this you can see 35 properties for all types of file and folders and it does not open any file..
Here is some code that worked successfully with 12,000 rows of data. It's a bit slow as it directly addresses each cell in each row. Minutes not hours. Be patient.
I tested it on my hard disc, a memory stick and a SD card, but not on a network file server but I see no reason why it should not work for that. With a bit more effort I think I could also make it work on a web file store.
I only tested it on my Windows 7 64 bit PC. It may not work on an earlier OS.
I have identified a few issues with it.
It does not list hidden files. It does not list empty folders. It does not list folders or files where access is denied.
Interestingly it carries on if it encounters an error condition. I did not see any side-effects of this but there may be some ?
As it picks up the 35 column headings from the first file/folder it comes across it may do something strange on a root folder that only contains sub-folders.
When I was testing it was hanging Excel after a couple of thousand rows but I seem to have cured this with a DoEvents and/or by using a Public variable for the row counter instead of Static inside the recursive subroutine , this being my initial preference.
Also you can open many of the files from spreadsheet hyperlinks. BE WARNED this may be dangerous.
The file order is as discovered while the code iterates through the folders. You may have to sort or filter to make sense of it.
Option Explicit
Public nRow As Long
Sub MakeFilePropertiesReport()
Const REPORTSHEET As String = "All_Files"
Const STARTPATH As Variant = "C:\FILES"
Sheets(REPORTSHEET).Activate
Cells.ClearContents
Application.ScreenUpdating = False
GetFolderFileProperties (STARTPATH)
Application.ScreenUpdating = True
MsgBox "Done"
Application.StatusBar = False
End Sub
Sub GetFolderFileProperties(sFolderName As Variant)
Dim nColumn As Long
Dim oShell As Object, oFolder As Object, oFileName As Object
Application.StatusBar = nRow & " : " & sFolderName
Set oShell = CreateObject("Shell.Application")
Set oFolder = oShell.Namespace(sFolderName)
With oFolder
For Each oFileName In .Items
If IsEmpty(Cells(2, 1)) Then ' make column headers
Range("a1").Value = "Folder"
Range("b1").Value = "Full Name"
nRow = 1
For nColumn = 0 To 35 ' 35 is count of properties
Cells(nRow, nColumn + 3) = .GetDetailsOf(.Items, nColumn)
Next nColumn
End If
nRow = nRow + 1
Cells(nRow, 1).Value = sFolderName
Cells(nRow, 2).Value = sFolderName & "\" & .GetDetailsOf(oFileName, 0)
ActiveSheet.Hyperlinks.Add Anchor:=Cells(nRow, 3), Address:=Cells(nRow, 2).Text, ScreenTip:="BE CAREFUL"
DoEvents ' Desperation
For nColumn = 0 To 35
Cells(nRow, nColumn + 3) = .GetDetailsOf(oFileName, nColumn)
Next nColumn
If .GetDetailsOf(oFileName, 6) = "D" Then
GetFolderFileProperties (oFileName.Path) ' RECURSE ! !
End If
Next oFileName
End With
End Sub
Regards
Derek Turner
+++
>________________________________
> From: "1z@compuserve.com" 1z@compuserve.com>
>To: ExcelVBA@yahoogroups.com
>Sent: Saturday, 16 February 2013, 12:41
>Subject: Re: [ExcelVBA] Using Excel VBA to generate an archive of document metadata
>
>
>
>Hehehe.... The filesystem object is your friend!
>
>Lisa
>
>Sent: Fri, Feb 15, 2013 7:41 pm
>
>Subject: Re: [ExcelVBA] Using Excel VBA to generate an archive of document metadata
>
>I threw this together pretty quickly.
>with just a little testing.
>
>hope it gives you someplace to start.
>
>----------------------------------------------------------
>Option Explicit
>'err.number & ": " & err.description
>Public fso, ListRow, RepSheet
>Sub List_All_Files()
>Dim StartPath, stat, File_Cnt
>'---------------------------------
>StartPath = "C:\temp"
>RepSheet = "All_Files"
>'---------------------------------
>Set fso = CreateObject("scripting.filesystemobject")
>'---------------------------------
>stat = Clear_Report
>'---------------------------------
>File_Cnt = Get_Folders(StartPath)
>'---------------------------------
>Application.StatusBar = False
>MsgBox File_Cnt & " files listed"
>End Sub
>Function Get_Folders(FolderName)
>Dim File, Files, f, fil
>Dim Folders, Folder
>Dim File_Cnt
>Application.StatusBar = "Accessing folder: " & FolderName
>On Error Resume Next
>Set Folder = fso.getfolder(FolderName)
>Set Files = Folder.Files
>For Each File In Files
>File_Cnt = File_Cnt + 1
>ListRow = ListRow + 1
>Set f = fso.getfile(File.Path)
>Sheets(RepSheet).Cells(ListRow, "A").Value = f.Name
>Sheets(RepSheet).Cells(ListRow, "B").Value = f.Path
>Sheets(RepSheet).Cells(ListRow, "C").Value = f.Size
>Sheets(RepSheet).Cells(ListRow, "D").Value = f.datecreated
>Sheets(RepSheet).Cells(ListRow, "E").Value = f.datelastmodified
>Sheets(RepSheet).Cells(ListRow, "F").Value = Get_Author(f.Path)
>
>' If (File_Cnt Mod 100 = 0) Then Application.StatusBar = Share_Name & ":
>Folders: " & Fldr_Cnt & " Files: " & File_Cnt
>Next File
>'--------------------------------------------------------
>Set Folders = Folder.subfolders
>For Each Folder In Folders
>File_Cnt = File_Cnt + Get_Folders(Folder)
>Next Folder
>'--------------------------------------------------------
>On Error GoTo 0
>Get_Folders = File_Cnt
>End Function
>Function Clear_Report()
>Sheets(RepSheet).Range("A2:Z1000000").ClearContents
>Sheets(RepSheet).Range("A1").Value = "FileName"
>Sheets(RepSheet).Range("B1").Value = "Path"
>Sheets(RepSheet).Range("C1").Value = "Size"
>Sheets(RepSheet).Range("D1").Value = "Date Created"
>Sheets(RepSheet).Range("E1").Value = "Date Modified"
>ListRow = 1
>End Function
>Function Get_Author(fullname)
>Dim Ext
>Ext = fso.getextensionname(fullname)
>Select Case UCase(Ext)
>Case "XLS", "XLSX", "XLSM", "XLSB"
>Application.Workbooks.Open fullname
>Get_Author = ActiveWorkbook.BuiltinDocumentProperties("Last author")
>ActiveWorkbook.Close savechanges:=False
>Case "DOC", "DOCX", "DOCM", "DOCB"
>End Select
>
>End Function
>
>Paul
>-----------------------------------------
>"Do all the good you can,
>By all the means you can,
>In all the ways you can,
>In all the places you can,
>At all the times you can,
>To all the people you can,
>As long as ever you can." - John Wesley
>-----------------------------------------
>
>[Non-text portions of this message have been removed]
>
>
>
>
>
[Non-text portions of this message have been removed]
| Reply via web post | Reply to sender | Reply to group | Start a New Topic | Messages in this topic (8) |
Be sure to check out TechTrax Ezine for many, free Excel VBA articles! Go here: http://www.mousetrax.com/techtrax to enter the ezine, then search the ARCHIVES for EXCEL VBA.
----------------------------------
Visit our ExcelVBA group home page for more info and support files:
http://groups.yahoo.com/group/ExcelVBA
----------------------------------
More free tutorials and resources available at:
http://www.mousetrax.com
----------------------------------
Tidak ada komentar:
Posting Komentar