1 Sub FileIndex()
2
3 ' This procedure requires that a reference be made to
4 ' the Microsoft Word Object Library (Tools | References)
5
6
7 Dim Directory As String
8 Dim FileName As String
9 Dim IndexSheet As Worksheet
10 Dim rw As Long
11 Dim Wd As Word.Application
12 Dim WdDoc As Word.Document
13 Dim WBook As Workbook
14
15 Application.ScreenUpdating = False
16
17 'Change the directory below to the appropriate folder
18 Directory = "C:\My Documents\"
19
20 'Create the Index Sheet and set the column names
21 Set IndexSheet = ThisWorkbook.Sheets.Add
22 On Error Resume Next
23 Application.DisplayAlerts = False
24 ThisWorkbook.Sheets("Index").Delete
25 Application.DisplayAlerts = True
26 On Error GoTo 0
27 IndexSheet.Name = "Index"
28 With IndexSheet
29 rw = 1
30 .Cells(rw, 1).Value = "File Name"
31 .Cells(rw, 2).Value = "Author"
32 .Cells(rw, 3).Value = "Title"
33 .Cells(rw, 4).Value = "Subject"
34 .Cells(rw, 5).Value = "Path"
35 .Cells(rw, 6).Value = "Comments"
36 .Cells(rw, 7).Value = "Last Saved On"
37 .Cells(rw, 8).Value = "Last Saved By"
38 rw = rw + 1
39 End With
40
41 'Start with the Excel Files
42 FileName = Dir(Directory & "*.xl*")
43 Do While FileName <> "" And FileName <> ThisWorkbook.Name
44 Application.StatusBar = "Retrieving information from " & FileName
45
46 Set WBook = Workbooks.Open(FileName:=Directory & FileName, _
47 UpdateLinks:=False, _
48 ReadOnly:=True)
49
50 With IndexSheet
51 .Hyperlinks.Add Anchor:=.Cells(rw, 1), _
52 Address:=Directory & FileName, _
53 TextToDisplay:=FileName
54 .Cells(rw, 2).Value = WBook.BuiltinDocumentProperties("Author").Value
55 .Cells(rw, 3).Value = WBook.BuiltinDocumentProperties("Title").Value
56 .Cells(rw, 4).Value = WBook.BuiltinDocumentProperties("Subject").Value
57 .Cells(rw, 5).Value = Directory
58 .Cells(rw, 6).Value =
WBook.BuiltinDocumentProperties("Comments").Value
59 .Cells(rw, 7).Value = WBook.BuiltinDocumentProperties("Last Save
Time").Value
60 .Cells(rw, 8).Value = WBook.BuiltinDocumentProperties("Last
Author").Value
61 End With
62
63 WBook.Close savechanges:=False
64 rw = rw + 1
65 Set WBook = Nothing
66 FileName = Dir
67 Loop
68
69 'Now do the Word Files
70 Set Wd = New Word.Application
71 FileName = Dir(Directory & "*.doc")
72 Do While FileName <> ""
73
74 Application.StatusBar = "Retrieving information from " & FileName
75
76 Set WdDoc = Wd.Documents.Open(FileName:=Directory & FileName, _
77 ReadOnly:=True, _
78 AddToRecentFiles:=False, _
79 Visible:=False)
80 With IndexSheet
81 .Hyperlinks.Add Anchor:=Cells(rw, 1), _
82 Address:=Directory & FileName, _
83 TextToDisplay:=FileName
84 .Cells(rw, 2).Value = WdDoc.BuiltinDocumentProperties("Author").Value
85 .Cells(rw, 3).Value = WdDoc.BuiltinDocumentProperties("Title").Value
86 .Cells(rw, 4).Value = WdDoc.BuiltinDocumentProperties("Subject").Value
87 .Cells(rw, 5).Value = Directory
88 .Cells(rw, 6).Value =
WdDoc.BuiltinDocumentProperties("Comments").Value
89 .Cells(rw, 7).Value = WdDoc.BuiltinDocumentProperties("Last Save
Time").Value
90 .Cells(rw, 8).Value = WdDoc.BuiltinDocumentProperties("Last
Author").Value
91 End With
92
93 WdDoc.Close savechanges:=False
94 rw = rw + 1
95 Set WdDoc = Nothing
96 FileName = Dir
97 Loop
98
99 Wd.Quit savechanges:=False
100 Set Wd = Nothing
101
102 Application.StatusBar = False
103 Application.ScreenUpdating = True
104
105 End Sub
**************
Send me an idea
that I can use in this column and I'll send you $5.00. Just make sure that
the subject contains the words "Idea for ABC," so that it will get past my
filters.
**************
FOLLOW UP FROM ANTHONY:
Chad ... I tried this today and it is exactly what I'm been looking for.
THANK YOU THANK YOU THANK YOU. Believe it or not, I've been asking
about this for two years with all the experts I know and even inquired
within Microsoft with no answer. I am attempting to modify the code now to
include other applications like Powerpoint, Access, Adobe, image files, or
to cover all the possibilities. I'm not that strong in VB but I think I can
follow the existing format. I'm also interested to know if you can
make the code read all the sub-directories beneath the primary without
having to change "Line 18" every time. But for now.... THANK YOU THANK YOU
THANK YOU.
PS. Keep the money, I should be paying you.
,
