Modification to existing Code
 

The below code works GREAT -- WITHOUT the 3 <<<THIS IS NEW LINE
That appear below. I'm wanting to extract the text that is in
The Workbook.Properties Dialog box - Subject Line (2) and have it
Placed in the cell to the right of the File Name.

Right Now I'm getting a Compile Error - Invalid Qualifier. ?? to me..
Any assistance appreciated.

Sub ListFiles(sFolder As String)
Dim wks As Worksheet
Dim lRowIndex As Long
Dim NumFiles As Long

Dim fso As FileSystemObject
Set fso = New FileSystemObject
'Either set a reference to Microsoft Scripting Runtime (Tools
References)
'or uncomment following two lines and comment previous two.
'Dim fso As Object
'Set fso = CreateObject("Scripting.FileSystemObject")

Dim fsoFiles As Files
Dim fsoFile As File
Dim fname As String
Dim fSubject As String <<<<< THIS IS NEW LINE
Application.ScreenUpdating = False
Set fsoFiles = fso.GetFolder(sFolder).Files

lRowIndex = 0
Set wks = Sheets.Add
For Each fsoFile In fsoFiles
fname = fsoFile.Name
fSubject = fname.BuiltinDocumentProperties(2) <<< THIS IS NEW
LINE
If LCase(fso.GetExtensionName(fname)) = "xls" Then
lRowIndex = lRowIndex + 1
wks.Cells(lRowIndex, 1).Value = fname
wks.Cells(lRowIndex, 2).Value = fSubject <<<< THIS IS NEW LINE
End If
If lRowIndex wks.Rows.Count Then Exit For
Next
Selection.CurrentRegion.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Copy
Sheets("Sheet1").Select
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
NumFiles = Range("B65536").End(xlUp).Row - 4
Range("A1").Value = NumFiles
Range("C1").Value = Now()
Range("B5").Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Modification to existing Code
 

Jim,

I don't think you will be able to get properties like that on closed
workbooks. Look at this previous posting of mine http://tinyurl.com/lk7h8

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Jim May" wrote in message
news:leuqg.51796$fG3.47245@dukeread09...
The below code works GREAT -- WITHOUT the 3 <<<THIS IS NEW LINE
That appear below. I'm wanting to extract the text that is in
The Workbook.Properties Dialog box - Subject Line (2) and have it
Placed in the cell to the right of the File Name.

Right Now I'm getting a Compile Error - Invalid Qualifier. ?? to me..
Any assistance appreciated.

Sub ListFiles(sFolder As String)
Dim wks As Worksheet
Dim lRowIndex As Long
Dim NumFiles As Long

Dim fso As FileSystemObject
Set fso = New FileSystemObject
'Either set a reference to Microsoft Scripting Runtime (Tools
References)
'or uncomment following two lines and comment previous two.
'Dim fso As Object
'Set fso = CreateObject("Scripting.FileSystemObject")

Dim fsoFiles As Files
Dim fsoFile As File
Dim fname As String
Dim fSubject As String <<<<< THIS IS NEW LINE
Application.ScreenUpdating = False
Set fsoFiles = fso.GetFolder(sFolder).Files

lRowIndex = 0
Set wks = Sheets.Add
For Each fsoFile In fsoFiles
fname = fsoFile.Name
fSubject = fname.BuiltinDocumentProperties(2) <<< THIS IS NEW
LINE
If LCase(fso.GetExtensionName(fname)) = "xls" Then
lRowIndex = lRowIndex + 1
wks.Cells(lRowIndex, 1).Value = fname
wks.Cells(lRowIndex, 2).Value = fSubject <<<< THIS IS NEW LINE
End If
If lRowIndex wks.Rows.Count Then Exit For
Next
Selection.CurrentRegion.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Copy
Sheets("Sheet1").Select
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
NumFiles = Range("B65536").End(xlUp).Row - 4
Range("A1").Value = NumFiles
Range("C1").Value = Now()
Range("B5").Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Modification to existing Code
 

Bob,
Thanks for the code.. It's a bit over my head..
Looks like it considers Word files as well as Excel.
I strictly need Excel files to extract from.
Not sure how to modify what you've presented
Thanks,

Jim

"Bob Phillips" wrote in message
:

Jim,

I don't think you will be able to get properties like that on closed
workbooks. Look at this previous posting of mine http://tinyurl.com/lk7h8

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Jim May" wrote in message
news:leuqg.51796$fG3.47245@dukeread09...

The below code works GREAT -- WITHOUT the 3 <<<THIS IS NEW LINE
That appear below. I'm wanting to extract the text that is in
The Workbook.Properties Dialog box - Subject Line (2) and have it
Placed in the cell to the right of the File Name.

Right Now I'm getting a Compile Error - Invalid Qualifier. ?? to me..
Any assistance appreciated.

Sub ListFiles(sFolder As String)
Dim wks As Worksheet
Dim lRowIndex As Long
Dim NumFiles As Long

Dim fso As FileSystemObject
Set fso = New FileSystemObject
'Either set a reference to Microsoft Scripting Runtime (Tools
References)
'or uncomment following two lines and comment previous two.
'Dim fso As Object
'Set fso = CreateObject("Scripting.FileSystemObject")

Dim fsoFiles As Files
Dim fsoFile As File
Dim fname As String
Dim fSubject As String <<<<< THIS IS NEW LINE
Application.ScreenUpdating = False
Set fsoFiles = fso.GetFolder(sFolder).Files

lRowIndex = 0
Set wks = Sheets.Add
For Each fsoFile In fsoFiles
fname = fsoFile.Name
fSubject = fname.BuiltinDocumentProperties(2) <<< THIS IS NEW
LINE
If LCase(fso.GetExtensionName(fname)) = "xls" Then
lRowIndex = lRowIndex + 1
wks.Cells(lRowIndex, 1).Value = fname
wks.Cells(lRowIndex, 2).Value = fSubject <<<< THIS IS NEW LINE
End If
If lRowIndex wks.Rows.Count Then Exit For
Next
Selection.CurrentRegion.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Copy
Sheets("Sheet1").Select
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
NumFiles = Range("B65536").End(xlUp).Row - 4
Range("A1").Value = NumFiles
Range("C1").Value = Now()
Range("B5").Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Modification to existing Code
 

I don't see that Word or Excel has anything to do with it JIm, the DSO code
takes whatever file you throw at it that has document properties. Your code
(the FSO code) needs to extract just Excel files, and call DSO for those.

Here is a further example that uses FSO to pass each Excel file and extract
just the properties to an array. Maybe you can adapt this

Option Explicit


Const COL_Application As String = 1
Const COL_Author As String = 2
Const COL_Version As String = 3
Const COL_Subject As String = 4
Const COL_Category As String = 5
Const COL_Company As String = 6
Const COL_Keywords As String = 7
Const COL_Manager As String = 8
Const COL_LastSavedBy As String = 9
Const COL_WordCount As String = 10
Const COL_PageCount As String = 11
Const COL_ParagraphCount As String = 12
Const COL_LineCount As String = 13
Const COL_CharacterCount As String = 14
Const COL_CharacterCountspaces As String = 15
Const COL_ByteCount As String = 16
Const COL_PresFormat As String = 17
Const COL_SlideCount As String = 18
Const COL_NoteCount As String = 19
Const COL_HiddenSlides As String = 20
Const COL_MultimediaClips As String = 21
Const COL_DateCreated As String = 22
Const COL_DateLastPrinted As String = 23
Const COL_DateLastSaved As String = 24
Const COL_TotalEditingTime As String = 25
Const COL_Template As String = 26
Const COL_Revision As String = 27
Const COL_IsShared As String = 28
Const COL_CLSID As String = 29
Const COL_ProgID As String = 30
Const COL_OleFormat As String = 1
Const COL_OleType As String = 32


Sub ListFileAttributes()
Dim FSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object
Dim this As Workbook
Dim aryFiles
Dim cnt As Long
Dim sh As Worksheet


Set FSO = CreateObject("Scripting.FileSystemObject")


Set this = ActiveWorkbook
sFolder = "C:\MyTest"
Set Folder = FSO.GetFolder(sFolder)
Set Files = Folder.Files
cnt = 0
ReDim aryFiles(1 To 33, 1 To 1)
For Each file In Files
If file.Type = "Microsoft Excel Worksheet" Then
Call DSO(file.Path, aryFiles)
End If
Next file


On Error Resume Next
Set sh = Worksheets("ListOfFiles")
On Error GoTo 0
If sh Is Nothing Then
Worksheets.Add.Name = "ListOfFiles"
Else
sh.Cells.ClearContents
End If


For i = LBound(aryFiles, 2) To UBound(aryFiles, 2)
Cells(i + 1, "A").Value = aryFiles(COL_Author, i)
Next i
Columns("A:C").AutoFit


End Sub


Sub DSO(ByVal FileName As String, ByRef aryData)
Static notFirstTime As Boolean
Dim fOpenReadOnly As Boolean
Dim DSO As DSOFile.OleDocumentProperties
Dim oSummProps As DSOFile.SummaryProperties
Dim oCustProp As DSOFile.CustomProperty
Dim iNext As Long


If notFirstTime Then
iNext = UBound(aryData, 2) + 1
Else
iNext = UBound(aryData, 2)
notFirstTime = True
End If
ReDim Preserve aryData(1 To 33, 1 To iNext)


Set DSO = New DSOFile.OleDocumentProperties
DSO.Open FileName, fOpenReadOnly, dsoOptionOpenReadOnlyIfNoWriteAccess


'Get the SummaryProperties (these are built-in set)...
Set oSummProps = DSO.SummaryProperties
aryData(1, iNext) = oSummProps.ApplicationName
aryData(2, iNext) = oSummProps.Author
aryData(3, iNext) = oSummProps.Version
aryData(4, iNext) = oSummProps.Subject
aryData(5, iNext) = oSummProps.Category
aryData(6, iNext) = oSummProps.Company
aryData(7, iNext) = oSummProps.Keywords
aryData(8, iNext) = oSummProps.Manager
aryData(9, iNext) = oSummProps.LastSavedBy
aryData(10, iNext) = oSummProps.WordCount
aryData(11, iNext) = oSummProps.PageCount
aryData(12, iNext) = oSummProps.ParagraphCount
aryData(13, iNext) = oSummProps.LineCount
aryData(14, iNext) = oSummProps.CharacterCount
aryData(15, iNext) = oSummProps.CharacterCountWithSpaces
aryData(16, iNext) = oSummProps.ByteCount
aryData(17, iNext) = oSummProps.PresentationFormat
aryData(18, iNext) = oSummProps.SlideCount
aryData(19, iNext) = oSummProps.NoteCount
aryData(20, iNext) = oSummProps.HiddenSlideCount
aryData(21, iNext) = oSummProps.MultimediaClipCount
aryData(22, iNext) = oSummProps.DateCreated
aryData(23, iNext) = oSummProps.DateLastPrinted
aryData(24, iNext) = oSummProps.DateLastSaved
aryData(25, iNext) = oSummProps.TotalEditTime
aryData(26, iNext) = oSummProps.Template
aryData(27, iNext) = oSummProps.RevisionNumber
aryData(28, iNext) = oSummProps.SharedDocument
'Add a few other items that pertain to OLE files only...
If DSO.IsOleFile Then
aryData(29, iNext) = DSO.CLSID
aryData(30, iNext) = DSO.progID
aryData(31, iNext) = DSO.OleDocumentFormat
aryData(32, iNext) = DSO.OleDocumentType
End If


'Now the custom properties
For Each oCustProp In DSO.CustomProperties
aryData(33, iNext) = CStr(oCustProp.Value)
Next oCustProp


Set oCustProp = Nothing
Set oSummProps = Nothing
Set DSO = Nothing


End Sub


--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Jim May" wrote in message
news:wiwqg.51804$fG3.49521@dukeread09...
Bob,
Thanks for the code.. It's a bit over my head..
Looks like it considers Word files as well as Excel.
I strictly need Excel files to extract from.
Not sure how to modify what you've presented
Thanks,

Jim

"Bob Phillips" wrote in message
:

Jim,

I don't think you will be able to get properties like that on closed
workbooks. Look at this previous posting of mine
http://tinyurl.com/lk7h8

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Jim May" wrote in message
news:leuqg.51796$fG3.47245@dukeread09...

The below code works GREAT -- WITHOUT the 3 <<<THIS IS NEW LINE
That appear below. I'm wanting to extract the text that is in
The Workbook.Properties Dialog box - Subject Line (2) and have it
Placed in the cell to the right of the File Name.

Right Now I'm getting a Compile Error - Invalid Qualifier. ?? to me..
Any assistance appreciated.

Sub ListFiles(sFolder As String)
Dim wks As Worksheet
Dim lRowIndex As Long
Dim NumFiles As Long

Dim fso As FileSystemObject
Set fso = New FileSystemObject
'Either set a reference to Microsoft Scripting Runtime (Tools
References)
'or uncomment following two lines and comment previous two.
'Dim fso As Object
'Set fso = CreateObject("Scripting.FileSystemObject")

Dim fsoFiles As Files
Dim fsoFile As File
Dim fname As String
Dim fSubject As String <<<<< THIS IS NEW LINE
Application.ScreenUpdating = False
Set fsoFiles = fso.GetFolder(sFolder).Files

lRowIndex = 0
Set wks = Sheets.Add
For Each fsoFile In fsoFiles
fname = fsoFile.Name
fSubject = fname.BuiltinDocumentProperties(2) <<< THIS IS NEW
LINE
If LCase(fso.GetExtensionName(fname)) = "xls" Then
lRowIndex = lRowIndex + 1
wks.Cells(lRowIndex, 1).Value = fname
wks.Cells(lRowIndex, 2).Value = fSubject <<<< THIS IS NEW
LINE
End If
If lRowIndex wks.Rows.Count Then Exit For
Next
Selection.CurrentRegion.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
Selection.Copy
Sheets("Sheet1").Select
Range("B5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
NumFiles = Range("B65536").End(xlUp).Row - 4
Range("A1").Value = NumFiles
Range("C1").Value = Now()
Range("B5").Select
Application.CutCopyMode = False
Application.DisplayAlerts = False
Sheets(1).Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub