<

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x

CustomDocumentProperties class

Published on
8,970 Points
2,870 Views
1 Endorsement
Last Modified:
Approved
I routinely try to process CustomDocumentProperties using the VBA interface adding, modifying and deleting according to some other code.  In a recent question on EE the need to address data types was indicated to ensure change data was of the correct or at least a compatible type.

My past approach has been to use functions defined in a normal module but it made me think about using a class for the purpose and this is therefore my attempt at a class for vba control of custom document properties.  Note the specific policy was to prevent errors and therefore except when essential components being omitted then there will be no errors reported.   For example if you try to delete a property that does not exist then there will be no resultant error.

The methods supported are:
propAdd – add a property, if pre-exists then no action
propDelete – delete a property, if not found then no error
propUpdate – updates an existing property, if not found then no action
propWrite – forces a write, creates if necessary and changes to a compatible data type if required

Initialisation requirements:
setDoc – identifies the document that the property relates to
setNewPropValue – A value to be posted to the property
setPropName – the name of the property to be processed

Interrogatives:
getExists – Does the property exist?
getPropName – name of the property, provided for the test interface
getPropType – the data type of the property
getPropValue – the value currently stored in the document

To create a class, in your application(s) of choice and in the VBE, (if you are not familiar with the VB Editor I would suggest the article is inappropriate for you) :
Insert Class Module

Rename the class module, in the test below class name clsCustomDocumentProperty is assumed.  Insert the code for the class as follows

Private objDoc As Object
Private objApp As Object
Private strgetPropName As String
Private varProperty As Variant
Private vargetPropType As MsoDocProperties
Private varCurrentgetPropValue As Variant
Private varNewgetPropValue As Variant
Private newDataTypeDate As Boolean
Private bolExists As Boolean

Private Sub Class_Initialize()
    bolExists = False
End Sub

Private Sub Class_Terminate()
End Sub

Public Property Let setDoc(objDocument As Object)
        
    Set objDoc = objDocument
    Set objApp = objDocument.Application

End Property

Public Property Let setPropName(strPropName As String)
        
    strgetPropName = strPropName
    bolExists = testExists()

End Property

Public Property Let setNewPropValue(varData)
                
    varNewgetPropValue = varData
    vargetPropType = DatumMSO
    
End Property

Public Property Get getExists() As Boolean
    getExists = bolExists
End Property

Private Property Get testExists() As Boolean
Dim prop As Variant

    testExists = False
    For Each prop In objDoc.CustomDocumentProperties
        If LCase(prop.Name) = LCase(strgetPropName) Then
            testExists = True
            Set varProperty = prop
            With varProperty
                vargetPropType = .Type
                varCurrentgetPropValue = .Value
            End With
            Exit For
        End If
    Next

End Property

Public Property Get getPropName() As String
       
    getPropName = strgetPropName

End Property

Public Property Get getPropValue() As String
        
    If bolExists Then
        getPropValue = varCurrentgetPropValue
    Else
        getPropValue = ""
    End If

End Property

Public Property Get getPropType() As String
        
    If bolExists Then
        getPropType = vargetPropType
    Else
        getPropType = ""
    End If

End Property

Private Property Get getNewPropValue()
    getNewPropValue = varNewgetPropValue
End Property

Private Property Get isgetNewValueTypeString() As Boolean
    isgetNewValueTypeString = (TypeName(varNewgetPropValue) = "String")
End Property

Private Property Get isgetNewValueTypeDate() As Boolean
    isgetNewValueTypeDate = (TypeName(varNewgetPropValue) = "Date")
End Property

Private Property Get isgetNewValueTypeNumber() As Boolean
    isgetNewValueTypeNumber = (TypeName(varNewgetPropValue) = "Integer")
End Property

Private Property Get isgetNewValueTypeFloat() As Boolean
    isgetNewValueTypeFloat = ((TypeName(varNewgetPropValue) = "Double") Or (TypeName(varNewgetPropValue) = "Single"))
End Property

Private Property Get isgetNewValueTypeBoolean() As Boolean
    isgetNewValueTypeBoolean = (TypeName(varNewgetPropValue) = "Boolean")
End Property

Private Property Get getNewValueType() As String
    getNewValueType = TypeName(varNewgetPropValue)
End Property

Private Property Get DatumMSO() As MsoDocProperties

    If isgetNewValueTypeString Then
        DatumMSO = msoPropertyTypeString
    ElseIf isgetNewValueTypeDate Then
        DatumMSO = msoPropertyTypeDate
    ElseIf isgetNewValueTypeNumber Then
        DatumMSO = msoPropertyTypeNumber
    ElseIf isgetNewValueTypeFloat Then
        DatumMSO = msoPropertyTypeFloat
    ElseIf isgetNewValueTypeBoolean Then
        DatumMSO = msoPropertyTypeBoolean
    End If

End Property

Sub propDelete()
        
    If bolExists Then
        varProperty.Delete
        bolExists = testExists()
    End If

End Sub

Sub propUpdate()

    If bolExists Then
        If vargetPropType = DatumMSO Then
            varProperty.Value = getNewPropValue
        End If
    End If

End Sub

Sub propWrite()
    
    If bolExists Then
        If vargetPropType = DatumMSO Then
            varProperty.Value = getNewPropValue
        Else
            propDelete
            propAdd
        End If
    Else
        propAdd
    End If

End Sub

Sub propAdd()

    If Not bolExists Then
        objDoc.CustomDocumentProperties.Add Name:=strgetPropName, _
            LinkToContent:=False, Type:=DatumMSO, Value:=varNewgetPropValue
        bolExists = testExists()
    End If

End Sub

Open in new window


Use the class in your application by declaring and instantiating a variable to the class and setting the key parameters, for example the document, (setDoc) excel/word/powerpoint etc., where the customdocumentproperties should reside and the name of the property you are interested in, (setPropName).  Additionally if setting to a value then you need to set the new datum, (setNewPropValue).

Some example uses are as in the subsequent example scripts.

Option Explicit

Sub test1()
Dim clsCDP1 As clsCustomDocumentProperty
Dim arr As Variant
Dim itm As Variant
Dim entity As Object

    Set entity = GetObject(, "word.application").documents(1)
    
    Set clsCDP1 = New clsCustomDocumentProperty
    clsCDP1.setDoc = entity
    clsCDP1.setPropName = "fred"
    Debug.Print clsCDP1.getPropName & " Exists :> " & clsCDP1.getExists

    With New clsCustomDocumentProperty
        .setDoc = entity
        .setPropName = "fred"
        .setNewPropValue = "Temp val!"
        .propAdd
        Debug.Print .getPropName & " Exists :> " & .getExists
        .propDelete
        Debug.Print .getPropName & " Exists :> " & .getExists
    End With

    arr = Array(22, 22.1, "fred", CDate("22 Feb 1922"), True)
    For Each itm In arr
        With New clsCustomDocumentProperty
            .setDoc = entity
            .setPropName = "fred"
            .setNewPropValue = itm
            .propAdd
            .propUpdate
            Debug.Print "'" & .getPropName & "' New data type (" & itm & ") updated? :> " & (.getPropValue = itm)
        End With
    Next

    arr = Array(22, 22.1, "fred", CDate("22 Feb 1922"), True)
    For Each itm In arr
        With New clsCustomDocumentProperty
            .setDoc = entity
            .setPropName = "fred"
            .setNewPropValue = itm
            .propWrite
            Debug.Print "'" & .getPropName & "' New data type (" & itm & ") force written? :> " & (.getPropValue = itm)
        End With
    Next

    With New clsCustomDocumentProperty
        .setDoc = entity
        .setPropName = "fred"
        .propDelete
    End With
    
    Set entity = CreateObject("excel.application")
    entity.workbooks.Add
    entity.Visible = True
    With New clsCustomDocumentProperty
        .setDoc = entity.workbooks(1)
        .setPropName = "fred"
        .setNewPropValue = "Temp val!"
        .propAdd
        Debug.Print .getPropName & " Exists :> " & .getExists
        .propDelete
        Debug.Print .getPropName & " Exists :> " & .getExists
    End With
    entity.Application.displayalerts = False
    entity.Quit

    Set entity = CreateObject("powerpoint.application")
    entity.presentations.Add
    entity.Visible = True
    With New clsCustomDocumentProperty
        .setDoc = entity.presentations(1)
        .setPropName = "fred"
        .setNewPropValue = "Temp val!"
        .propAdd
        Debug.Print .getPropName & " Exists :> " & .getExists
        .propDelete
        Debug.Print .getPropName & " Exists :> " & .getExists
    End With
'    entity.Application.displayalerts = False
    entity.Quit

End Sub

Open in new window


Chris
1
1 Comment
LVL 18

Expert Comment

by:Simon
Nice article, Chris. Deserves some 'helpful' votes. I haven't tried running the code myself yet. One question - Does it overcome the horrible habit Word has of interpreting -some- UK dates as US ones? I currently push all my dates to text to avoid this.
0

Featured Post

PMI ACP® Project Management

Prepare for the PMI Agile Certified Practitioner (PMI-ACP)® exam, which formally recognizes your knowledge of agile principles and your skill with agile techniques.

In this video you will find out how to export Office 365 mailboxes using the built in eDiscovery tool. Bear in mind that although this method might be useful in some cases, using PST files as Office 365 backup is troublesome in a long run (more on t…
The Relationships Diagram is a good way to get an overall view of what a database is keeping track of. It is also where relationships are defined. A relationship specifies how two tables connect to each other. As you build tables in Microsoft Ac…
Other articles by this author

Keep in touch with Experts Exchange

Tech news and trends delivered to your inbox every month