Solved

Exporting Word properies

Posted on 2013-11-13
11
226 Views
Last Modified: 2013-11-14
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?
0
Comment
Question by:PLA_LTM
  • 6
  • 3
  • 2
11 Comments
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39647591
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 39647748
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
 

Author Comment

by:PLA_LTM
ID: 39647895
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 39647904
I tested and got no pop ups ... do you get an inkling on what they are asking / saying?
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 39647912
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
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 39647919
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
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 250 total points
ID: 39647948
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
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39648016
Hi

@ chris_bottomley
According to documentation 4 is wdPropertyKeywords and 14 wdPropertyPages

That's why I used 14
Regards
0
 
LVL 48

Expert Comment

by:Rgonzo1971
ID: 39648069
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
 

Author Closing Comment

by:PLA_LTM
ID: 39648263
Chris this is exactly what i needed.
Thank you so much!!
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 39648277
Glad it helped

Chris
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

If you work with Word a lot, you probably use styles. If you use styles a lot, you've probably balled your fist more often than not when working with the ribbon. In Word 2007/2010, one of the things that I find missing when using styles is a quic…
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
This video teaches the viewer how to align pictures around text while keeping the text properly aligned in the document.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

744 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now