Add Custom Property to a Document

[Mavila]

I'm trying to add custom document properties to a document but it doesn't seem to be working. The code runs fine without any errors but the properties and their values are never added/saved to the document. My code is as follows:


ActiveDocument.CustomDocumentProperties.Add Name:="SD_Date_Created", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=strDateCreated

ActiveDocument.Close savechanges:=wdSaveChanges

Must be missing something simple but I'll be darned if I can figure it out! Macro recorder doesn't work for this one. Intellisense doesn't seem to work either.

[gmayor]

It works for me, but there are provisos. Have you defined what strCreated is? Does the property already exist in the document? The following should address both.


Sub Macro1()
Dim strDateCreated As String
Dim oProp As Object
Dim bExists As Boolean
Dim fso As Object
Dim fDoc As Object


If ActiveDocument.Path = "" Then
ActiveDocument.Save
End If
If ActiveDocument.Path = "" Then GoTo lbl_Exit


Set fso = CreateObject("Scripting.FileSystemObject")
Set fDoc = fso.GetFile(ActiveDocument.FullName)


strDateCreated = Format(fDoc.DateCreated, "dd/mm/yyyy")


For Each oProp In ActiveDocument.CustomDocumentProperties
If oProp.Name = "SD_Date_Created" Then
oProp.Value = strDateCreated
bExists = True
Exit For
End If
Next oProp
If Not bExists Then
ActiveDocument.CustomDocumentProperties.Add _
Name:="SD_Date_Created", _
LinkToContent:=False, _
Type:=msoPropertyTypeString, _
Value:=strDateCreated
End If
ActiveDocument.Close wdSaveChanges
lbl_Exit:
Set fDoc = Nothing
Set fso = Nothing
Set oProp = Nothing
Exit Sub
End Sub

[Mavila]

Thank you for your reply. To answer your questions, strCreated is defined, and, no, the property doesn't exist.

Here is the entirety of the code (it's still in development, so there are a few extra lines of code for testing purposes):


Sub Get_Poster_Data()
'Declarations
Dim Poster_Parameters As String
Dim strFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
strFolder = .SelectedItems(1) & "\"
End If
End With
Dim TMrgn As Long
Dim BMrgn As Long
Dim RMrgn As Long
Dim LMrgn As Long
Dim strDateCreated As String
Dim strDateExpires As String
Dim strIDNum As String

If strFolder <> "" Then
Dim myFile As String
myFile = Dir(strFolder)
Do While myFile <> ""
If myFile Like "*.docx" Then
Documents.Open FileName:=strFolder & myFile
'Determine Custom Document Properties as they currently exist (values are in points rather than inches)
With ActiveDocument.PageSetup
TMrgn = .TopMargin
BMrgn = .BottomMargin
RMrgn = .RightMargin
LMrgn = .LeftMargin
End With
With ActiveDocument.Bookmarks 'ID_Num, Date_Created, Date_Expires - derived from bookmarks in the document
If .Exists("Date_Created") = True Then
strDateCreated = .Item("Date_Created").Range
End If
If .Exists("Date_Expires") = True Then
strDateExpires = .Item("Date_Expires").Range
End If
If .Exists("ID_Number") = True Then
strIDNum = .Item("ID_Number").Range
End If
End With

Dim answr As Long
answr = MsgBox("Do you want to delete existing Custom Properties?", vbYesNo + vbQuestion, "Delete Existing Custom Properties")
If answr = vbYes Then
'Delete Existing Custom Properties (Custom Properties includes system generated properties, too, which I don't want to delete)
Dim prop As DocumentProperty
For Each prop In ActiveDocument.CustomDocumentProperties
If prop.Name Like "SD_*" Then
MsgBox "Property Name is " & prop.Name & Chr(13) & "Property Value is " & prop.Value & "."
Stop
prop.Delete 'Delete Existsing Custom Properties
End If
Next
'Add New Custom Properties 4/13/2017
Stop
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Date_Created", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=strDateCreated
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Date_Expires", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=strDateExpires
ActiveDocument.CustomDocumentProperties.Add Name:="SD_ID_Number", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=IDNum
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Top_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=TMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Bottom_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=BMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Right_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=RMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Left_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=LMrgn
Else 'Change/Confirm values of custom properties
If Poster_Parameters = "" Then
Poster_Parameters = "File Name: " & myFile & "|" & "Date Created: " & strDateCreated & "|" & "Expiration Date: " & strDateExpires & "|" & "ID Number: " & IDNum & "|" & "Top Margin: " & TMrgn & "|" & "Bottom Margin: " & BMrgn & "|" & "Right Margin: " & RMrgn & "|" & "Left Margin: " & LMrgn & "|"
ElseIf Poster_Parameters <> "" Then
Poster_Parameters = Poster_Properties & "^" & "File Name: " & myFile & "|" & "Date Created: " & strDateCreated & "|" & "Expiration Date: " & strDateExpires & "|" & "ID Number: " & IDNum & "|" & "Top Margin: " & TMrgn & "|" & "Bottom Margin: " & BMrgn & "|" & "Right Margin: " & RMrgn & "|" & "Left Margin: " & LMrgn & "|"
End If
End If
End If
ActiveDocument.Close savechanges:=wdSaveChanges
myFile = Dir
Stop
Loop
answr = MsgBox("Do you want to view Custom Properties for each Poster", vbYesNo + vbQuestion, "View Custom Properties?")
If answr = vbYes Then
Dim b As Long
Dim myMsg As String
Dim PstrSplit As Variant
Dim CPropSplit As Variant
PstrSplit = Split(Poster_Parameters, "^")
For a = 0 To UBound(PstrSplit) 'Loop through the file names
If myMsg = "" Then 'Do nothing
ElseIf myMsg <> "" Then
myMsg = myMsg & Chr(13)
End If
CPropSplit = Split(PstrSplit(a), "|")
For b = 0 To UBound(CPropSplit)
If myMsg = "" Then
myMsg = CPropSplit(b)
Else
myMsg = myMsg & "; " & CPropSplit(b)
End If
Next
Next
MsgBox (myMsg)
Else
End If
End If
End Sub

[gmayor]

Can you post an example document to test your code.

[Mavila]

I've not done this before, so I hope it worked.

[Mavila]

OK, this gets a bit weirder. If I create a new "clean" document and run only the following the code:


ActiveDocument.CustomDocumentProperties.Add Name:="SD_Date_Created", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=strDateCreated
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Date_Expires", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=strDateExpires
ActiveDocument.CustomDocumentProperties.Add Name:="SD_ID_Number", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=IDNum
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Top_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=TMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Bottom_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=BMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Right_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=RMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Left_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=LMrgn

It works fine. The Custom Properties are added but without the values because no values are assigned to the variables. But it won't work on the original document.

I should point out, I guess, that the original document was a pdf conversion to a Word document. When it was converted, there were three custom properties created - "Created" (type = date), "Creator" (type = text = Adobe LiveCycle Designer), and "Last Saved" (type = date). When I run the macro to delete these three properties, it doesn't delete them - it runs fine without error but it doesn't actually delete them. I can manually delete them but the macro doesn't work. Just like the Add method.

So, exploring some more, I decided to do a Select All (cntrl+A), Copy (cntrl+C) of the original document's contents and then Paste it into a new, "clean" document (cntrl+V). The custom properties created by the pdf-to-Word conversion do not copy over. But the macro Add method for custom properties still doesn't work.

If all of that isn't weird enough, I started getting a compile error (duplicate in same scope) for my variable declarations:
Dim TMrgn As Long
Dim BMrgn As Long
Dim RMrgn As Long
Dim LMrgn As Long
Dim strDateCreated As String
Dim strDateExpires As String
Dim strIDNum As String

Of course, they are not duplicates in the same scope, so this is totally baffling.

Any help is greatly appreciated!

I'm thinking I might have to store the data in an Access database so I can move on. But it's frustrating that this won't work.:banghead:

[gmayor]

There are a few issues with your code. There are some missing variables and there are some wrongly named variables, which probably accounts for several of the error messages. If you add Option Explicit to the top of the module, such errors become obvious when you compile the code.

Your code doesn't delete the three existing custom properties because your code conditionally deletes only properties that being with 'SD_'

If prop.Name Like "SD_*" Then
The margin values are written to the new variables. The other variables are read from bookmarks in the document. There are only two bookmarks in the example document 'Date_Expires' and 'ID_Number' so the CreatedDate value is never going to be created, as the bookmark from which that value is obtained doesn't exist. The creation date is a built-in docvariable so you can get it from there.

You may find http://www.gmayor.com/BookmarkandVariableEditor.htm useful as it lists all the bookmarks, and document properties and their values in the current document. This should help you see where the problems lie.

The following should work.


Option Explicit

Sub Get_Poster_Data()
'Declarations
Dim Poster_Parameters As String
Dim strFolder As String
Dim TMrgn As Long
Dim BMrgn As Long
Dim RMrgn As Long
Dim LMrgn As Long
Dim strDateCreated As String
Dim strDateExpires As String
Dim strIDNum As String
Dim a As Long, b As Long
Dim myMsg As String
Dim PstrSplit As Variant
Dim CPropSplit As Variant
Dim answr As Long
Dim myFile As String
Dim prop As DocumentProperty

With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
strFolder = .SelectedItems(1) & "\"
End If
End With

If strFolder <> "" Then
myFile = Dir(strFolder)
Do While myFile <> ""
If myFile Like "*.docx" Then
Documents.Open FileName:=strFolder & myFile
'Determine Custom Document Properties as they currently exist (values are in points rather than inches)
With ActiveDocument.PageSetup
TMrgn = .TopMargin
BMrgn = .BottomMargin
RMrgn = .RightMargin
LMrgn = .LeftMargin
End With

'Debug.Print TMrgn & vbTab & BMrgn & vbTab & RMrgn & vbTab & LMrgn

With ActiveDocument.Bookmarks 'ID_Num, Date_Created, Date_Expires - derived from bookmarks in the document
If .Exists("Date_Expires") = True Then
strDateExpires = .Item("Date_Expires").Range
End If
If .Exists("ID_Number") = True Then
strIDNum = .Item("ID_Number").Range
End If
End With


strDateCreated = ActiveDocument.BuiltInDocumentProperties("Creation Date").Value


answr = MsgBox("Do you want to delete existing Custom Properties?", vbYesNo + vbQuestion, "Delete Existing Custom Properties")
If answr = vbYes Then
'Delete Existing Custom Properties (Custom Properties includes system generated properties, too, which I don't want to delete)
For Each prop In ActiveDocument.CustomDocumentProperties
'If prop.Name Like "SD_*" Then
MsgBox "Property Name is " & prop.Name & Chr(13) & "Property Value is " & prop.Value & "."
'Stop
prop.Delete 'Delete Existsing Custom Properties
'End If
Next
'Add New Custom Properties 4/13/2017
'Stop
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Date_Created", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=strDateCreated
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Date_Expires", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=strDateExpires
ActiveDocument.CustomDocumentProperties.Add Name:="SD_ID_Number", LinkToContent:=False, Type:=msoPropertyTypeString, Value:=strIDNum
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Top_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=TMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Bottom_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=BMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Right_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=RMrgn
ActiveDocument.CustomDocumentProperties.Add Name:="SD_Left_Margin", LinkToContent:=False, Type:=msoPropertyTypeNumber, Value:=LMrgn
'Else 'Change/Confirm values of custom properties
If Poster_Parameters = "" Then
Poster_Parameters = "File Name: " & myFile & "|" & "Date Created: " & strDateCreated & "|" & "Expiration Date: " & strDateExpires & "|" & "ID Number: " & strIDNum & "|" & "Top Margin: " & TMrgn & "|" & "Bottom Margin: " & BMrgn & "|" & "Right Margin: " & RMrgn & "|" & "Left Margin: " & LMrgn & "|"
ElseIf Poster_Parameters <> "" Then
Poster_Parameters = Poster_Parameters & "^" & "File Name: " & myFile & "|" & "Date Created: " & strDateCreated & "|" & "Expiration Date: " & strDateExpires & "|" & "ID Number: " & strIDNum & "|" & "Top Margin: " & TMrgn & "|" & "Bottom Margin: " & BMrgn & "|" & "Right Margin: " & RMrgn & "|" & "Left Margin: " & LMrgn & "|"
End If
End If
End If
ActiveDocument.Close savechanges:=wdSaveChanges
myFile = Dir
Loop
answr = MsgBox("Do you want to view Custom Properties for each Poster", vbYesNo + vbQuestion, "View Custom Properties?")
If answr = vbYes Then
PstrSplit = Split(Poster_Parameters, "^")
For a = 0 To UBound(PstrSplit) 'Loop through the file names
If myMsg = "" Then 'Do nothing
ElseIf myMsg <> "" Then
myMsg = myMsg & Chr(13)
End If
CPropSplit = Split(PstrSplit(a), "|")
For b = 0 To UBound(CPropSplit)
If myMsg = "" Then
myMsg = CPropSplit(b)
Else
myMsg = myMsg & "; " & CPropSplit(b)
End If
Next
Next
MsgBox (myMsg)
Else
End If
End If
lbl_Exit:
Exit Sub
End Sub

[Mavila]

Thanks, Graham, for hanging in there with me. I changed those things about the variables you mentioned. I changed the properties deleting loop to delete all properties. Incidentally, my SD_Date_Created is not the date the document was created, it's the date that the contents of the document were created (a date in the text of the document captured with the bookmark if it exists).

Anyway, I tidied things up and ran it and I was getting the same thing. It deleted existing properties and then added them. I created a loop to run after the properties were added that confirmed that they were added. Then the code closed the document saving the changes.

But it still wasn't working. The added properties and values weren't saved. Then, I ran across this thread:
http://www.vbaexpress.com/forum/showthread.php?16678-Custom-Document-Properties-Don-t-Always-Save

If you scroll down to the post by, TonyJollans, he explains that changes to properties aren't considered as changes to the document (I don't really understand the explanation as to why). I noticed when I ran the code and saved changes to the documents after adding the properties/values that the date/time didn't change on the document at all.

TonyJollans' solution was to add, "ActiveDocument.Saved = False" and that triggers the saving of the properties. I added this line of code to the line just before saving/closing the document. I don't understand exactly why that's needed, but it does, in fact, work! My problem is resolved now. I appreciate you spending the time to help me out.