Why won't CustomDocProperties stick to doc after close??!?

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance

I have a set of Word files in a folder and a list of values in an
Excel spread***. I'm running a macro in Excel to iterate through
each doc and add the values in the spread*** as
CustomDocumentProperties. I have a Debug.Print at the end of the
macro to read the properties from each doc, and the properties are
read just fine.

But when I ran another macro in Excel to iterate throgh the doc and
read these properties into another spread***, the properties weren't
there! When I opened the docs and looked at File >> Properties, no
Custom Properties were listed!

Why won't these stick to the docs??

Ed
(Word and Excel 2000)

Sub AddPropsToSongs()

Dim strDoc As String

Dim wkb As Workbook
Dim wks As Work***
Dim x As Long, y As Long

Dim WD As Word.Application
Dim doc As Word.Document

Set wkb = ActiveWorkbook
Set wks = wkb.Worksheets("Songs")

y = wks.Range("B10000").End(xlUp).Row + 1

On Error Resume Next
Set WD = GetObject(, Word.Application)
If WD.Name = "" Then _
Set WD = New Word.Application

WD.Visible = True

For x = 2 To y
If wks.Range("A" & x).Text <> "" Then
strDoc = wks.Range("C" & x).Text
Set doc = WD.Documents.Open(strDoc)

With doc.CustomDocumentProperties
.Add _
Name:="cpFastSlow", LinkToContent:=False, _
Value:=wks.Range("A" & x).Text, _
Type:=msoPropertyTypeString
.Add _
Name:="cpName", LinkToContent:=False, _
Value:=wks.Range("B" & x).Text, _
Type:=msoPropertyTypeString
.Add _
Name:="cpFLine", LinkToContent:=False, _
Value:=wks.Range("D" & x).Text, _
Type:=msoPropertyTypeString
.Add _
Name:="cpCLine", LinkToContent:=False, _
Value:=wks.Range("E" & x).Text, _
Type:=msoPropertyTypeString
End With

doc.Save

Debug.Print doc.CustomDocumentProperties("cpFastSlow").Value
Debug.Print doc.CustomDocumentProperties("cpName").Value
Debug.Print doc.CustomDocumentProperties("cpFLine").Value
Debug.Print doc.CustomDocumentProperties("cpCLine").Value
Debug.Print "****************"

doc.Close

End If
Next x
On Error GoTo 0

EndMe:
WD.Quit
Set WD = Nothing

MsgBox "I'm done!"

End Sub

Sub ReadDocProps()

Dim MyDir As String
Dim strDoc As String

Dim wkb As Workbook
Dim wks As Work***
Dim x As Long

Dim WD As Word.Application
Dim doc As Word.Document
Dim prop

On Error Resume Next
Set WD = GetObject(, Word.Application)
If WD.Name = "" Then _
Set WD = New Word.Application
On Error GoTo 0

Set wkb = ActiveWorkbook
Set wks = wkb.Worksheets("Sheet1")
x = 0

MyDir = "C:\Documents and Settings\Ed\Desktop\Songs"
strDoc = Dir(MyDir & "\*.doc")

While strDoc <> ""
Set doc = WD.Documents.Open(MyDir & "\" & strDoc)
x = wks.Range("A10000").End(xlUp).Row + 1

wks.Cells(x, 1) = doc.CustomDocumentProperties("cpFastSlow").Value
wks.Cells(x, 2) = doc.CustomDocumentProperties("cpName").Value
wks.Cells(x, 4) = doc.CustomDocumentProperties("cpFLine").Value
wks.Cells(x, 5) = doc.CustomDocumentProperties("cpCLine").Value
wks.Cells(x, 3) = MyDir & "\" & strDoc

doc.Close

strDoc = Dir()

Wend

wkb.Save

EndMe:
WD.Quit
Set WD = Nothing

MsgBox "I'm done!"

End Sub
.

Quantcast