List of Excel files with document properties

[Tiglet]

Hi,

I am trying to extract a full list of all Excel Spreadsheets on a drive showing their path and various document properties. I have found this excellent example on the web

http://www.exceltip.com/show_tip/Fi...Runtime_using_VBA_in_Microsoft_Excel/446.html

which works almost perfectly. However, I want to include in the properties that it lists out, the author's name and I can't work out how to do it. Any suggestions would be gratefully received. I have scoured the net to see if I can find something but to no avail.

Many Thanks

Tiglet

Living on Earth is expensive, but it does include a free trip around the sun every year

 

[SkipVought]

T,

Take a look a the DocumentProperty Object

DocumentProperty Object


Represents a custom or built-in document property of a container document. The DocumentProperty object is a member of the DocumentProperties collection.

Using the DocumentProperty Object

Use BuiltinDocumentProperties(index), where index is the name or index number of the built-in document property, to return a single DocumentProperty object that represents a specific built-in document property. Use CustomDocumentProperties(index), where index is the name or index number of the custom document property, to return a DocumentProperty object that represents a specific custom document property.

The following list contains the names of all the available built-in document properties:

Title
Subject

Author

Keywords

Comments

Template

Last Author

Revision Number

Application Name

Last Print Date

Creation Date

Last Save Time

Total Editing Time

Number of Pages
Number of Words
Number of Characters

Security

Category

Format

Manager

Company

Number of Bytes

Number of Lines

Number of Paragraphs

Number of Slides

Number of Notes

Number of Hidden Slides

Number of Multimedia Clips



Container applications don't necessarily define a value for every built-in document property. If a given application doesn't define a value for one of the built-in document properties, returning the Value property for that document property causes an error.

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[Tiglet]

Skip,

Yep, I tried that but couldn't seem to get it to work in conjunction with the existing code. I don't think I'm defining it correctly. My code is at home, so I can post it in its entirety shortly

Cheers

Tiglet

Living on Earth is expensive, but it does include a free trip around the sun every year

 

[SkipVought]

Sub test()
    Dime rw as Long, p as BuiltinDocumentProperty
    rw = 1
    On Error Resume Next
    For Each p In ActiveWorkbook.BuiltinDocumentProperties
        With Cells(rw, 1)
            .Value = p.Name
            .Offset(0, 1).Value = p.Value
        End With
        rw = rw + 1
    Next

End Sub

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[Tiglet]

Skip,

Unfortunately, I've tried that and I think it kicks out because it is an ActiveWorkbook reference. I don't want to have to open every workbook as it will take forever, some may have passwords and I guess it would change the date last accessed property anyway. It will be running on Excel 2000 and I found this:-

http://www.codecomments.com/archive299-2005-2-410755.html

and these

http://www.mrexcel.com/archive2/44200/51340.htm

http://www.microsoft.com/technet/community/columns/scripts/sg0305.mspx

http://www.cpearson.com/excel/docprop.htm

but I can’t combine them and am just way out my of depth

here is my code

Sub TestListFilesInFolder()
Dim objdrive As Object
Dim Driveletter As String
Dim boxtitle, Name

Rem Dim Drive_Select As String
'Sets names for all bits of user defined information
Driveletter = Range("c14").Value
'Captures the drive letter selected in the drop down list
answerdrive = MsgBox("You are about to audit " & Driveletter & " Is this correct?", vbYesNo, " Excel Hunter")
If answerdrive = vbNo Then Call HelpSelectDrive
If answerdrive = vbNo Then Exit Sub
'Gives user an "Are you sure" escape clause
'On Error GoTo Err_Trap
'Will exit routine with a message explaining the problem if an invalid drive has been selected from the drop down list e.g. an unmapped one
    Workbooks.Add
    ' create a new workbook for the file list
    With Range("A1")
        .Formula = "Folder contents:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    'Puts header in big font on worksheet
    Range("A3").Formula = "File Name:"
    Range("B3").Formula = "File Size (Kb):"
    Range("C3").Formula = "File Type:"
    Range("D3").Formula = "Date Created:"
    Range("E3").Formula = "Date Last Accessed:"
    Range("F3").Formula = "Date Last Modified:"
    Range("G3").Formula = "Author:"
    Range("H3").Formula = "Last Modified By:"
    Range("H3").Formula = "File Name:"
    Range("I3").Formula = "Short File Name:"
    Range("A3:I3").Font.Bold = True
    'Puts column headers in worksheet
   ListFilesInFolder Driveletter, True
    MsgBox "Excel Spreadsheets on Drive " & Driveletter, vbOKOnly, "Macro completed"
    'Tells user that macro has completed
   Exit Sub
Err_Trap:
Application.DisplayAlerts = False
 'Turns off automatic "Are you sure" message boxes
ActiveWorkbook.Close
'Closes workbook created with all the headings
MsgBox "Doh! Please select a valid drive letter" & Chr(13) & "e.g. C:\", vbExclamation, " Muppet Instructions"
'Tells the user that they have picked an invalid drive
Application.DisplayAlerts = True
'Turns back on the automatic "Are you sure" messages
End Sub


Sub ListFilesInFolder(SourceFolderName As String, IncludeSubfolders As Boolean)

Dim objdrive As Object
Dim XLSFileName As String
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim DSO As DSOFile.OleDocumentProperties
Set DSO = New DSOFile.OleDocumentProperties
Dim FileItem As Scripting.File
Dim strauthor As BuiltinDocumentProperty
Dim lstAuthor As String
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
   
   r = Range("A65536").End(xlUp).Row + 1
   
For Each FileItem In SourceFolder.Files
  'If FileItem.Name = "" Then Exit Sub
    XLSFileName = Cells(r, 8).Formula
    'DSO.Open sfilename:=FileItem.Name
    XLSFileName.ChangeFileAccess xlReadOnly
  DSO.Open FileItem.Path
      If FileItem.Name = "" Then Exit Sub
  
    On Error Resume Next
        If FileItem.Name Like ("*.xls") Then Cells(r, 1).Formula = FileItem.Path
        If FileItem.Name Like ("*.xls") Then Cells(r, 2).Formula = FileItem.Size / 1024
        If FileItem.Name Like ("*.xls") Then Cells(r, 3).Formula = FileItem.Type
        If FileItem.Name Like ("*.xls") Then Cells(r, 4).Formula = FileItem.DateCreated
        If FileItem.Name Like ("*.xls") Then Cells(r, 5).Formula = FileItem.DateLastAccessed
        If FileItem.Name Like ("*.xls") Then Cells(r, 6).Formula = FileItem.DateLastModified
        If FileItem.Name Like ("*.xls") Then Cells(r, 7).Formula = strauthor
        If FileItem.Name Like ("*.xls") Then Cells(r, 8).Formula = FileItem.Name
        If FileItem.Name Like ("*.xls") Then Cells(r, 9).Formula = FileItem.ShortName
        If FileItem.Name Like ("*.xls") Then Cells(r, 10).Value = DSO.SummaryProperties.DateLastSaved
        If FileItem.Name Like ("*.xls") Then Cells(r, 11).Formula = DSO.SummaryProperties.ApplicationName
        If FileItem.Name Like ("*.xls") Then Cells(r, 12).Value = DSO.SummaryProperties.Author
        If FileItem.Name Like ("*.xls") Then Cells(r, 13).Value = DSO.SummaryProperties.DateLastPrinted
        If FileItem.Name Like ("*.xls") Then Cells(r, 14).Value = DSO.SummaryProperties.DateLastSaved
        If FileItem.Name Like ("*.xls") Then Cells(r, 15).Value = DSO.SummaryProperties.LastSavedBy
        If FileItem.Name Like ("*.xls") Then Cells(r, 16).Value = DSO.SummaryProperties.DateCreated
        If FileItem.Name Like ("*.xls") Then Cells(r, 17).Value = DSO.SummaryProperties.ByteCount
        
        If FileItem.Name Like ("*.xls") Then r = r + 1
        XLSFileName.ChangeFileAccess xlReadWrite
    Next FileItem

    If IncludeSubfolders Then
        For Each SubFolder In SourceFolder.SubFolders
            ListFilesInFolder SubFolder.Path, True
        Next SubFolder
    End If

    Columns("A:S").AutoFit
    Set FileItem = Nothing
    Set SourceFolder = Nothing
    Set FSO = Nothing
    ActiveWorkbook.Saved = True
    Exit Sub

End Sub

I apologise if it's awful coding, please bear with me, I said I would do this for a friend but didn't realise it would be so complicated and I'm now very stuck! :-(


Tiglet

Living on Earth is expensive, but it does include a free trip around the sun every year

 

[SkipVought]

T,

So where does it go awry?

Skip,
[sub]
[red]A palindrome gone wrong?[/red]
A man, a plan, a ROOT canal...
PULLEMALL![/sub]

 

[Tiglet]

On

 Dim strauthor As BuiltinDocumentProperty

it says "Compile Error User Defined Type not defined" I tried it as

 Dim strauthor As DocumentProperty

as well. Do I need to do something else so the

 BuiltinDocumentProperty

bit is defined?

Tiglet

Living on Earth is expensive, but it does include a free trip around the sun every year

 

[PHV]

Why not using DSO.SummaryProperties.Author instead ?

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[Tiglet]

I would if I could!!!

I have this.....

Sub test()

Dim FileName As String
Dim DSO As DSOFile.OleDocumentProperties
Set DSO = New DSOFile.OleDocumentProperties
r = 1
Workbooks.Add
Dim xlsname As String
Dim strauthor As String
FileName = "C:\document.xls"
DSO.Open sfilename:=FileName
strauthor = DSO.SummaryProperties.Author
xlsname = DSO.SummaryProperties.ApplicationName
Cells(r, 1).Formula = xlsname
'Debug.Print xlsname
'cells.
Cells(r, 2).Value = strauthor
Cells(r, 3).Value = DSO.SummaryProperties.DateLastPrinted
Cells(r, 4).Value = DSO.SummaryProperties.DateLastSaved
Cells(r, 5).Value = DSO.SummaryProperties.LastSavedBy
Cells(r, 6).Value = DSO.SummaryProperties.DateCreated
Cells(r, 7).Value = DSO.SummaryProperties.ByteCount
Cells(r, 8).Value = DSO.SummaryProperties.ByteCount

' lots of other properties
DSO.Close

End Sub

...........but I can't seem to incorporate it into the main macro - any help would be really appreciated, i have been going round in circles with this for weeks now!

Tiglet

Living on Earth is expensive, but it does include a free trip around the sun every year