How To Create a Custom Content Class With Date and Integer Custom Properties

Const URI_CONTENT_CLASS = "DAV:contentclass"
Const URI_EXPECTED_CONTENT_CLASS = _
    "urn:schemas-microsoft-com:exch-data:expected-content-class"
Const URI_SCHEMA_COLLECTION_REF = _
    "urn:schemas-microsoft-com:exch-data:schema-collection-ref"
Const URI_ISHIDDEN = "DAV:ishidden"
Const URI_NAME = "urn:schemas-microsoft-com:xml-data#name"
Const URI_TYPE = "urn:schemas-microsoft-com:datatypes#type"
Const URI_ISMULTIVALUED = _
    "urn:schemas-microsoft-com:exch-data:ismultivalued"
Const URI_ISINDEXED = "urn:schemas-microsoft-com:exch-data:isindexed"
Const URI_ISREADONLY = "urn:schemas-microsoft-com:exch-data:isreadonly"
Const URI_ELEMENT = "urn:schemas-microsoft-com:xml-data#element"
Const URI_CC_FOLDER = "urn:content-classes:folder"
Const URI_CC_CONTENTCLASSDEF = "urn:content-classes:contentclassdef"
Const URI_CC_PROPERTYDEF = "urn:content-classes:propertydef"

Dim cn As ADODB.Connection
Dim rec As ADODB.Record
Dim strRoot As String
Dim strAppURL As String
Dim strSchemaURL As String

' TO DO: Replace ServerName with your Exchange 2000 server name. 
strRoot = "http://ServerName/public/"
strAppURL = strRoot & "AppFolder/"
strSchemaURL = strAppURL & "Schema/"

Set cn = CreateObject("ADODB.Connection")
cn.Provider = "EXOLEDB.DATASOURCE"
cn.Open strRoot

' Create the Application folder.
Set rec = CreateObject("ADODB.Record")
With rec
    .Open strAppURL, cn, adModeReadWrite, _
        (adCreateCollection Or adCreateOverwrite)
    .Fields(URI_CONTENT_CLASS) = URI_CC_FOLDER
    .Fields(URI_SCHEMA_COLLECTION_REF) = "./Schema/"
    .Fields(URI_EXPECTED_CONTENT_CLASS) = Array( _
        "urn:schemas-domain-com:content-classes:test")
    .Fields.Update
    .Close
End With
Set rec = Nothing

' Create the Schema folder.
Set rec = CreateObject("ADODB.Record")
With rec
    .Open strSchemaURL, cn, adModeReadWrite, _
        (adCreateCollection Or adCreateOverwrite)
    .Fields(URI_CONTENT_CLASS) = URI_CC_FOLDER
    .Fields(URI_ISHIDDEN) = True
    .Fields.Update
    .Close
End With
Set rec = Nothing

' Fill the schema folder with content class definitions.
'Create a property definition.
Set rec = CreateObject("ADODB.Record")
With rec
    .Open strSchemaURL & "propdefName.reg", cn, adModeReadWrite, _
        adCreateNonCollection
    .Fields(URI_CONTENT_CLASS) = URI_CC_PROPERTYDEF
    .Fields(URI_NAME) = "urn:schemas-domain-com:Name"
    .Fields(URI_TYPE) = "string"
    .Fields(URI_ISMULTIVALUED) = False
    .Fields(URI_ISINDEXED) = False
    .Fields(URI_ISREADONLY) = False
    .Fields.Update
    .Close
End With
Set rec = Nothing

Set rec = CreateObject("ADODB.Record")
With rec
    .Open strSchemaURL & "propdefDate.reg", cn, adModeReadWrite, _
        adCreateNonCollection
    .Fields(URI_CONTENT_CLASS) = URI_CC_PROPERTYDEF
    .Fields(URI_NAME) = "urn:schemas-domain-com:Date"
    .Fields(URI_TYPE) = "dateTime"
    .Fields(URI_ISMULTIVALUED) = False
    .Fields(URI_ISINDEXED) = False
    .Fields(URI_ISREADONLY) = False
    .Fields.Update
    .Close
End With
Set rec = Nothing

Set rec = CreateObject("ADODB.Record")
With rec
    .Open strSchemaURL & "propdefNumber.reg", cn, adModeReadWrite, _
        adCreateNonCollection
    .Fields(URI_CONTENT_CLASS) = URI_CC_PROPERTYDEF
    .Fields(URI_NAME) = "urn:schemas-domain-com:Num"
    .Fields(URI_TYPE) = "int"
    .Fields(URI_ISMULTIVALUED) = False
    .Fields(URI_ISINDEXED) = False
    .Fields(URI_ISREADONLY) = False
    .Fields.Update
    .Close
End With
Set rec = Nothing

'Create a content class definition.
Set rec = CreateObject("ADODB.Record")
With rec
    .Open strSchemaURL & "ccdef.reg", cn, adModeReadWrite, _
        adCreateNonCollection
    .Fields(URI_CONTENT_CLASS) = URI_CC_CONTENTCLASSDEF
    .Fields(URI_NAME).Value = _
        "urn:schemas-domain-com:content-classes:test"

    .Fields(URI_ELEMENT).Value = Array( _
        "urn:schemas-domain-com:Name", _
        "urn:schemas-domain-com:Date", _
        "urn:schemas-domain-com:Num")
    .Fields.Update
    .Close
End With
Set rec = Nothing

cn.Close
Set cn = Nothing

Set cn = CreateObject("ADODB.Connection")
cn.Provider = "EXOLEDB.DATASOURCE"
cn.Open strAppURL

' Create a new record in AppFolder with the content class that you created. 
Set rec = CreateObject("ADODB.Record") With rec
Set rec = CreateObject("ADODB.Record")
With rec
    .Open "newrec.eml", cn, adModeReadWrite, adCreateNonCollection
    .Fields(URI_CONTENT_CLASS) = _
        "urn:schemas-domain-com:content-classes:test"
    .Fields("urn:schemas-domain-com:Name").Value = "greeting"
    .Fields("urn:schemas-domain-com:Date").Value = _
        CDate("4/7/2000 12:40:19 AM")
    .Fields("urn:schemas-domain-com:Num").Value = CLng("1001")
    .Fields.Update
    .Close
End With
Set rec = Nothing

cn.Close
Set cn = Nothing