Public Function SetCustomProperty(strPropName As String, intPropType _
As Integer, vntPropValue As Variant) As Boolean
Dim dbs As Database, cnt As Container
Dim doc As Document, prp As Property
Const conPropertyNotFound = 3270 ' Property not found error.
Set dbs = CurrentDb ' Define Database object.
Set cnt = dbs.Containers!Databases ' Define Container object.
Set doc = cnt.Documents!UserDefined ' Define Document object.
On Error GoTo SetCustom_Err
doc.Properties.Refresh
' Set custom property name. If error occurs here it means
' property doesn't exist and needs to be created and appended
' to Properties collection of Document object.
Set prp = doc.Properties(strPropName)
prp = vntPropValue ' Set custom property value.
SetCustomProperty = True
SetCustom_Bye:
Exit Function
SetCustom_Err:
If Err = conPropertyNotFound Then
Set prp = doc.CreateProperty(strPropName, intPropType, vntPropValue)
doc.Properties.Append prp ' Append to collection.
Resume Next
Else ' Unknown error.
SetCustomProperty = False
Resume SetCustom_Bye
End If
End Function
Public Function GetCustomProperty(strPropName As String) As Variant
Dim dbs As Database, cnt As Container
Dim doc As Document, prp As Property
' Property not found error.
Const conPropertyNotFound = 3270
On Error GoTo GetCustom_Err
Set dbs = CurrentDb
Set cnt = dbs.Containers!Databases
Set doc = cnt.Documents!UserDefined
doc.Properties.Refresh
GetCustomProperty = doc.Properties(strPropName)
GetCustom_Bye:
Exit Function
GetCustom_Err:
Resume GetCustom_Bye
End Function
Public Sub DeleteCustomProperty(strPropName As String)
Dim dbs As Database, cnt As Container
Dim doc As Document, prp As Property
' Property not found error.
Const conPropertyNotFound = 3270
On Error GoTo DeleteCustom_Err
Set dbs = CurrentDb
Set cnt = dbs.Containers!Databases
Set doc = cnt.Documents!UserDefined
doc.Properties.Refresh
doc.Properties.Delete strPropName
DeleteCustom_Bye:
Exit Sub
DeleteCustom_Err:
End Sub