Exporting Word properies

Hello Experts,

I have a folder which hold nothing but word documents.
Each of these documents contain a varying number of pages.

I'm wondering if  there is a way to export the name of these documents along with the page counts to an excel sheet?

Alternatively, is there a script in Excel to List files in a folder and their properties?
PLA_LTMAsked:
Who is Participating?
 
Chris BottomleySoftware Quality Lead EngineerCommented:
POrted my code to VBA that you can insert into an excel module.

Modified slightly: This flavour uses sheet one but keeps the code to add a new sheet into which to pour the data:

See the lines:

'Set xlws = ThisWorkbook.Sheets.Add
Set xlWS = ThisWorkbook.Sheets("Sheet1")


Option Explicit

Dim arr()
Dim wdApp
Dim intCount

Sub FilePAges()
Dim xlWS
Dim FSO
Dim folder
Dim files
Dim fil
Dim elem

On Error Resume Next
intCount = 0
ReDim arr(1, intCount)
Set FSO = CreateObject("Scripting.FileSystemObject")
Set folder = FSO.GetFolder("C:\DeleteMe\Lantau Songbook")
Set files = folder.files

Set wdApp = CreateObject("Word.application")
wdApp.Visible = False

For Each fil In files
    Q28293541_1 fil
Next
wdApp.Quit
'Set xlws = ThisWorkbook.Sheets.Add
Set xlWS = ThisWorkbook.Sheets("Sheet1")
xlWS.Cells.Delete
xlWS.Range("a2").Resize(UBound(arr, 2) + 1, 2).Value = Application.Transpose(arr)
xlWS.Range("a1") = "File Name"
xlWS.Range("b1") = "Page Count"
xlWS.Range("1:2").Columns.AutoFit

End Sub

Sub Q28293541_1(fn)
Dim doc

    If Right(LCase(fn), 5) = ".docx" Or Right(LCase(fn), 5) = ".docm" Or Right(LCase(fn), 4) = ".doc" Then
        If InStr(fn, "\~") = 0 Then
            ReDim Preserve arr(1, intCount)
            intCount = intCount + 1
            arr(0, intCount - 1) = fn.Path
            Set doc = wdApp.Documents.Open(fn.Path)
            arr(1, intCount - 1) = doc.Content.Information(4)
            doc.Close False
        End If
    End If

End Sub

Open in new window


Chris
0
 
Rgonzo1971Commented:
Hi,

pls try in an excel worbook

Sub FindProperties()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next
strDirectory =  "C:\MyDocuments\"
strFile = Dir(strDirectory & "*.doc*")
Set WD = CreateObject("Word.Application")
WD.Application.Visible = False
strFile = Dir
strFile = Dir
Do While strFile <> ""
    Set WdDoc = WD.Documents.Open(strDirectory & strFile)
    ActiveSheet.Range("A" & Idx).Value = strFile
    NbPages = WdDoc.BuiltinDocumentProperties(14)
    ActiveSheet.Range("A" & Idx).Offset(, 1).Value = NbPages
    WdDoc.Close False
    Idx = Idx + 1
    strFile = Dir
Loop

On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
WD.Quit
Set WD = Nothing
End Sub

Open in new window

Regards
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Take the following script and paste into a new file rename as a VBScript file for example Q_28293541.vbs.

Modify the line 9 folder to point to your folder and then after saving, execute the file.

Dim arr()
Dim wdApp
Dim intCount

On Error Resume Next
intCount = 0
ReDim arr(1, intCount)
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder("C:\DeleteMe\Lantau Songbook")
Set Files = folder.Files

Set wdApp = CreateObject("Word.application")
For Each fil In Files
    Q28293541_1 fil
Next
wdApp.Quit
For elem = 0 To UBound(arr, 2)
    WScript.echo arr(0, elem) & "     " & arr(1, elem)
Next
Set xlapp = CreateObject("excel.application")
Set xlwb = xlapp.workbooks.add
Set xlws = xlwb.sheets(1)
xlws.range("a2").resize(UBound(arr, 2) + 1, 2).value = xlapp.transpose(arr)
xlws.range("a1") = "File Name"
xlws.range("b1") = "Page Count"
xlws.range("1:2").columns.autofit
xlapp.visible = True

Sub Q28293541_1(fn)

    If Right(LCase(fn), 5) = ".docx" Or Right(LCase(fn), 5) = ".docm" Or Right(LCase(fn), 4) = ".doc" Then
        If instr(fn , "\~") = 0 Then
	        ReDim Preserve arr(1, intCount)
	        intCount = intCount + 1
	        arr(0, intCount - 1) = fn.Path
	        Set doc = wdApp.Documents.Open(fn.Path)
	        arr(1, intCount - 1) = doc.Content.Information(4)
	        doc.Close False
	    End If
    End If

End Sub

Open in new window


Chris
0
Cloud Class® Course: Microsoft Exchange Server

The MCTS: Microsoft Exchange Server 2010 certification validates your skills in supporting the maintenance and administration of the Exchange servers in an enterprise environment. Learn everything you need to know with this course.

 
PLA_LTMAuthor Commented:
Chris,

this is great.  this VBS works great.

I was hoping you can help tweak this a bit.
1) I see a dialog window pop up for each file with in this folder.  My ultimate target folder will have thousands of files, is there a way to suppress the dialog box?


2)is there a way i can embed this in an excel sheet, where when I open the excel workbook this macro just runs?  (sorry if this is a stupid question but I'm not very well versed in the coding world)
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
I tested and got no pop ups ... do you get an inkling on what they are asking / saying?
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
For embedding into excel see RGonzos post ... although I have not tested I do see an error at line 16:

NbPages = WdDoc.BuiltinDocumentProperties(14)

Which should use '4'

NbPages = WdDoc.BuiltinDocumentProperties(4)

That aside it may do what you ask

Chris
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
A slight tweak to mine (line 13 inserted) to suppress might be:

Dim arr()
Dim wdApp
Dim intCount

On Error Resume Next
intCount = 0
ReDim arr(1, intCount)
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder("C:\DeleteMe\Lantau Songbook")
Set Files = folder.Files

Set wdApp = CreateObject("Word.application")
wdApp.visible = false
For Each fil In Files
    Q28293541_1 fil
Next
wdApp.Quit
For elem = 0 To UBound(arr, 2)
    WScript.echo arr(0, elem) & "     " & arr(1, elem)
Next
Set xlapp = CreateObject("excel.application")
Set xlwb = xlapp.workbooks.add
Set xlws = xlwb.sheets(1)
xlws.range("a2").resize(UBound(arr, 2) + 1, 2).value = xlapp.transpose(arr)
xlws.range("a1") = "File Name"
xlws.range("b1") = "Page Count"
xlws.range("1:2").columns.autofit
xlapp.visible = True

Sub Q28293541_1(fn)

    If Right(LCase(fn), 5) = ".docx" Or Right(LCase(fn), 5) = ".docm" Or Right(LCase(fn), 4) = ".doc" Then
        If instr(fn , "\~") = 0 Then
	        ReDim Preserve arr(1, intCount)
	        intCount = intCount + 1
	        arr(0, intCount - 1) = fn.Path
	        Set doc = wdApp.Documents.Open(fn.Path)
	        arr(1, intCount - 1) = doc.Content.Information(4)
	        doc.Close False
	    End If
    End If

End Sub

Open in new window


Chris
0
 
Rgonzo1971Commented:
Hi

@ chris_bottomley
According to documentation 4 is wdPropertyKeywords and 14 wdPropertyPages

That's why I used 14
Regards
0
 
Rgonzo1971Commented:
Hi

Now using 4 with Information Property

Sub FindProperties()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next
strDirectory = "\\chca6037.eur.beluni.net\a853725$\Documents\" '  "C:\MyDocuments\"
strFile = Dir(strDirectory & "*.doc*")
Set WD = CreateObject("Word.Application")
WD.Application.Visible = False
strFile = Dir
strFile = Dir
Do While strFile <> ""
    Set WdDoc = WD.Documents.Open(strDirectory & strFile)
    ActiveSheet.Range("A" & Idx).Value = strFile
    WdDoc.Bookmarks("\EndOfDoc").Select
    NbPages = WD.Selection.Information(4)
    ActiveSheet.Range("A" & Idx).Offset(, 1).Value = NbPages
    WdDoc.Close False
    Idx = Idx + 1
    strFile = Dir
Loop

On Error GoTo 0
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
WD.Quit
Set WD = Nothing
End Sub

Open in new window

Regards
0
 
PLA_LTMAuthor Commented:
Chris this is exactly what i needed.
Thank you so much!!
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Glad it helped

Chris
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.