How to copy subtypes

Subtypes enable you to define different rules for categories of objects within a single geodatabase object class. This example shows how to copy all the subtypes from one object class (or feature class) to another. This may be useful if you have just copied an object class programmatically.
The code assumes that the two object classes have the same fields. If the destination object class is in a different geodatabase than the origin feature class, it should have the appropriate domains present, though the example code checks for this. If you use this code on a dataset that has not just been created, you should first ensure exclusive access via the ISchemaLock interface.

How to use

  1. Copy the two macros into your VB or VBA application.
  2. Edit the Main macro to point to your data. Export the OriginFC feature class to another geodatabase.
  3. Run the Main macro.
[VBA] 
Public Sub CopySubtypes(pOrigObjectClass As IObjectClass, pDestObjectClass As IObjectClass)
    
    Dim pOrigSubtypes As ISubtypes
    Dim pDestSubtypes As ISubtypes
    Set pOrigSubtypes = pOrigObjectClass
    Set pDestSubtypes = pDestObjectClass
    
    If Not pOrigSubtypes.HasSubtype Then
        Exit Sub
    End If
    
    ' Preparation for examining domains of the destination workspace -
    ' if we encounter any default domain settings for subtypes, we
    ' will need to check if the domain exists in the destination workspace
    Dim pDataset As IDataset
    Dim pDestWorkspaceDomains As IWorkspaceDomains
    Set pDataset = pDestObjectClass
    Set pDestWorkspaceDomains = pDataset.Workspace
    Dim pOrigDomain As IDomain
    Dim pDestDomain As IDomain
    
    ' Set which field governs the subtype
    pDestSubtypes.SubtypeFieldName = pOrigSubtypes.SubtypeFieldName
    
    ' Process each origin subtype in turn
    Dim pFields As IFields
    Set pFields = pOrigObjectClass.Fields
    Dim lSubtypeCode As Long
    Dim sSubtypeName As String
    Dim pEnumSubtypes As IEnumSubtype
    Set pEnumSubtypes = pOrigSubtypes.Subtypes
    pEnumSubtypes.Reset
    sSubtypeName = pEnumSubtypes.Next(lSubtypeCode)
    Do Until Len(sSubtypeName) = 0
        
        ' Add the subtype
        pDestSubtypes.AddSubtype lSubtypeCode, sSubtypeName
        
        ' For each field, set the default value and domain for this subtype
        Dim sFieldName As String
        Dim lCount As Long
        For lCount = 0 To pFields.FieldCount - 1
            sFieldName = pFields.Field(lCount).Name
            Dim vDefValue As Variant
            vDefValue = pOrigSubtypes.DefaultValue(lSubtypeCode, sFieldName)
            If Not IsNull(vDefValue) Then
                pDestSubtypes.DefaultValue(lSubtypeCode, sFieldName) = vDefValue
            End If
            
            Set pOrigDomain = pOrigSubtypes.Domain(lSubtypeCode, sFieldName)
            If Not pOrigDomain Is Nothing Then
                Set pDestDomain = pDestWorkspaceDomains.DomainByName(pOrigDomain.Name)
                If pDestDomain Is Nothing Then
                    Dim iResponse As Integer
                    iResponse = MsgBox(pOrigDomain.Name & ": domain does not exist in destination workspace", vbOKCancel)
                    If (iResponse = vbCancel) Then
                        Exit Sub
                    End If
                Else
                    Set pDestSubtypes.Domain(lSubtypeCode, sFieldName) = pDestDomain
                End If
            End If
            
        Next lCount
        
        sSubtypeName = pEnumSubtypes.Next(lSubtypeCode)
    Loop
    
    ' Set the default subtype
    pDestSubtypes.DefaultSubtypeCode = pOrigSubtypes.DefaultSubtypeCode
    
End Sub

Public Sub Main()
    Dim pOrigFeatWorkspace As IFeatureWorkspace
    Dim pDestFeatWorkspace As IFeatureWorkspace
    Dim pWSF As IWorkspaceFactory
    Set pWSF = New AccessWorkspaceFactory
    'Open the origin and destination workspaces. *** Modify the pathnames appropriately.
    Set pOrigFeatWorkspace = pWSF.OpenFromFile("D:\Data\Geodatabases\OriginGDB.mdb", 0)
    Set pDestFeatWorkspace = pWSF.OpenFromFile("D:\Data\Geodatabases\TargetGDB.mdb", 0)
    
    Dim pOrigFeatureClass As IFeatureClass
    Dim pDestFeatureClass As IFeatureClass
    'Open the origin and destination feature classes. *** Modify the feature class names appropriately.
    Set pOrigFeatureClass = pOrigFeatWorkspace.OpenFeatureClass("OriginFC")
    Set pDestFeatureClass = pDestFeatWorkspace.OpenFeatureClass("TargetFC")
    
    Call CopySubtypes(pOrigFeatureClass, pDestFeatureClass)
    
    MsgBox "Subytpes copied"
End Sub





Additional Requirements
  • Two Geodatabases, with the origin Geodatabase containing a feature class with subtypes.