How to add a DocumentProperty to CustomDocumentProperties in Excel? - vba

Question

I'm trying to add a DocumentProperty to the CustomDocumentProperties collection. Code as follows:
Sub testcustdocprop()
Dim docprops As DocumentProperties
Dim docprop As DocumentProperty
Set docprops = ThisWorkbook.CustomDocumentProperties
Set docprop = docprops.Add(Name:="test", LinkToContent:=False, Value:="xyz")
End Sub
Running this gives me the following error:
Run-time error '5':
Invalid procedure call or argument
I tried running it with .Add as a void function, like so:
docprops.Add Name:="test", LinkToContent:=False, Value:="xyz"
This gave me the same error. How do I add a custom document property?

Answer 1

Try this routine:
Public Sub updateCustomDocumentProperty(strPropertyName As String, _
varValue As Variant, docType As Office.MsoDocProperties)
On Error Resume Next
ActiveWorkbook.CustomDocumentProperties(strPropertyName).Value = varValue
If Err.Number > 0 Then
ActiveWorkbook.CustomDocumentProperties.Add _
Name:=strPropertyName, _
LinkToContent:=False, _
Type:=docType, _
Value:=varValue
End If
End Sub
Edit: Usage Examples
Five years later and the 'official' documentation is still a mess on this... I figured I'd add some examples of usage:
Set Custom Properties
Sub test_setProperties()
updateCustomDocumentProperty "my_API_Token", "AbCd1234", msoPropertyTypeString
updateCustomDocumentProperty "my_API_Token_Expiry", #1/31/2019#, msoPropertyTypeDate
End Sub
Get Custom Properties
Sub test_getProperties()
MsgBox ActiveWorkbook.CustomDocumentProperties("my_API_Token") & vbLf _
& ActiveWorkbook.CustomDocumentProperties("my_API_Token_Expiry")
End Sub
List All Custom Properties
Sub listCustomProps()
Dim prop As DocumentProperty
For Each prop In ActiveWorkbook.CustomDocumentProperties
Debug.Print prop.Name & " = " & prop.Value & " (" & Choose(prop.Type, _
"msoPropertyTypeNumber", "msoPropertyTypeBoolean", "msoPropertyTypeDate", _
"msoPropertyTypeString", "msoPropertyTypeFloat") & ")"
Next prop
End Sub
Delete Custom Properties
Sub deleteCustomProps()
ActiveWorkbook.CustomDocumentProperties("my_API_Token").Delete
ActiveWorkbook.CustomDocumentProperties("my_API_Token_Expiry").Delete
End Sub

Answer 2

I figured I should extend the above answer from 2013 to work without having to pass in the docType argument:
Private Function getMsoDocProperty(v As Variant) As Integer
'VB TYPES:
'vbEmpty 0 Empty (uninitialized)
'vbNull 1 Null (no valid data)
'vbInteger 2 Integer
'vbLong 3 Long integer
'vbSingle 4 Single-precision floating-point number
'vbDouble 5 Double-precision floating-point number
'vbCurrency 6 Currency value
'vbDate 7 Date value
'vbString 8 String
'vbObject 9 Object
'vbError 10 Error value
'vbBoolean 11 Boolean value
'vbVariant 12 Variant (used only with arrays of variants)
'vbDataObject 13 A data access object
'vbDecimal 14 Decimal value
'vbByte 17 Byte value
'vbUserDefinedType 36 Variants that contain user-defined types
'vbArray 8192 Array
'OFFICE.MSODOCPROPERTIES.TYPES
'msoPropertyTypeNumber 1 Integer value.
'msoPropertyTypeBoolean 2 Boolean value.
'msoPropertyTypeDate 3 Date value.
'msoPropertyTypeString 4 String value.
'msoPropertyTypeFloat 5 Floating point value.
Select Case VarType(v)
Case vbInteger, vbLong
getMsoDocProperty = Office.MsoDocProperties.msoPropertyTypeNumber
Case vbBoolean
getMsoDocProperty = Office.MsoDocProperties.msoPropertyTypeBoolean
Case vbDate
getMsoDocProperty = Office.MsoDocProperties.msoPropertyTypeDate
Case vbString, vbByte
getMsoDocProperty = Office.MsoDocProperties.msoPropertyTypeString
Case vbSingle, vbDouble, vbCurrency,vbDecimal
getMsoDocProperty = Office.MsoDocProperties.msoPropertyTypeFloat
Case Else
getMsoDocProperty = 0
End Select
End Function
Public Sub subUpdateCustomDocumentProperty(ByVal doc as object, ByVal strPropertyName As String, _
ByVal varValue As Variant, Optional ByVal docType As Office.MsoDocProperties = 0)
If docType = 0 Then docType = getMsoDocProperty(varValue)
If docType = 0 Then
MsgBox "An error occurred in ""subUpdateCustomDocumentProperty"" routine", vbCritical
Exit Sub
End If
On Error Resume Next
doc.CustomDocumentProperties(strPropertyName).Value _
= varValue
If Err.Number > 0 Then
doc.CustomDocumentProperties.Add _
Name:=strPropertyName, _
LinkToContent:=False, _
Type:=docType, _
Value:=varValue
End If
End Sub