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?

Improve company productivity with a Business Account.Sign Up

x
 
Chris BottomleyConnect With a Mentor Commented:
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 BottomleyCommented:
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
Free Tool: SSL Checker

Scans your site and returns information about your SSL implementation and certificate. Helpful for debugging and validating your SSL configuration.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

 
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 BottomleyCommented:
I tested and got no pop ups ... do you get an inkling on what they are asking / saying?
0
 
Chris BottomleyCommented:
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 BottomleyCommented:
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 BottomleyCommented:
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.