Solved

Exporting Word properies

Posted on 2013-11-13
11
233 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 49

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
Netscaler Common Configuration How To guides

If you use NetScaler you will want to see these guides. The NetScaler How To Guides show administrators how to get NetScaler up and configured by providing instructions for common scenarios and some not so common ones.

 
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
 
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 49

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 49

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

PRTG Network Monitor: Intuitive Network Monitoring

Network Monitoring is essential to ensure that computer systems and network devices are running. Use PRTG to monitor LANs, servers, websites, applications and devices, bandwidth, virtual environments, remote systems, IoT, and many more. PRTG is easy to set up & use.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

The Selection object is designed for user interaction. It has a Range property, so it can be used in most places that a Range object can. Recorded macros must use the Selection because they are simply copying what the user is doing. A Range prope…
This is written from a 'VBA for MS Word' perspective, but I am sure it applies to most other MS Office components where VBA is used.  One thing that really bugs me is slow code, ESPECIALLY when it's mine!  In programming there are so many ways to…
Learn how to make your own table of contents in Microsoft Word using paragraph styles and the automatic table of contents tool. We'll be using the paragraph styles in Word’s Home toolbar to help you create a table of contents. Type out your initial …
This Micro Tutorial well show you how to find and replace special characters in Microsoft Word. This is similar to carriage returns to convert columns of values from Microsoft Excel into comma separated lists.

809 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