Copying Subtypes

Created:07/12/2001
Description:

Subtypes enable you to define different rules for categories of object 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 programatically.

The code assumes that the two object classes have the same fields. If the destination object class is in a different geodatabase to the origin, 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 TestCopySubtypes macro to point to your data. As a suggestion you could use the Greeley geodatabase that is built with the 'Creating and Populating a Geodatabase' sample. Export the SNPoles feature class to another geodatabase.
  3. Run the TestCopySubtypes macro.
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 TestCopySubtypes()
  Dim pOrigFeatWorkspace As IFeatureWorkspace
  Dim pDestFeatWorkspace As IFeatureWorkspace
  Dim pWSF As IWorkspaceFactory
  Set pWSF = New AccessWorkspaceFactory
  Set pOrigFeatWorkspace = pWSF.OpenFromFile("C:\arcgis\arcexe83\ArcObjects Developer Kit\Samples\Geodatabase\Database Tools\Creating and Populating a Geodatabase\Greeley.mdb", 0)
  Set pDestFeatWorkspace = pWSF.OpenFromFile("D:\Data\Geodatabases\Test.mdb", 0)

  Dim pOrigFeatureClass As IFeatureClass
  Dim pDestFeatureClass As IFeatureClass
  Set pOrigFeatureClass = pOrigFeatWorkspace.OpenFeatureClass("SNPoles")
  Set pDestFeatureClass = pDestFeatWorkspace.OpenFeatureClass("SNPoles")
  
  Call CopySubtypes(pOrigFeatureClass, pDestFeatureClass)
  
  MsgBox "Finished"
End Sub