How to put features via attribute transfer

This sample puts selected features from a source to destination layer. The source and destination layer are defined in the Spatial Adjustment Attribute Transfer Mapping dialog, found under the Spatial Adjustment menu on the Spatial Adjustment toolbar. This dialog also lets you map attributes between the source and destination features.

How to use

  1. Open the Attribute Transfer Mapping dialog, from the Spatial Adjustment menu on the Spatial Adjustment toolbar.
  2. Set the source/target layers and desired field mapping.
  3. Select source features to be put into the target layer.
  4. Paste the following code into VBA and run the subroutine PutViaAttributeTransfer.
[VBA] 
Public Sub PutViaAttributeTransfer()
    
    'Copy geometry and attributes from selected features to a target layer
    'Define source, target and attributes to be transfered via
    'Spatial Adjustment Attribute Transfer Mapping dialog.
    
    Dim pMxDoc As IMxDocument
    Dim pMap As IMap
    Dim pEditor As IEditor
    Dim pAttTransType As IAttributeTransferType
    Dim pAttTrans As IAttributeTransfer
    Dim pATDS As IAttributeTransferDefaultSettings
    
    Dim pSourceFeatLyr As IFeatureLayer2
    Dim pTargetFeatLyr As IFeatureLayer2
    Dim pFieldMap As IFieldMap
    
    Dim pEnumFeat As IEnumFeature
    Dim pSourceFeature As IFeature
    Dim pTargetFeature As IFeature
    Dim bATSucess As Boolean
    
    'Get the doc and Map
    Set pMxDoc = ThisDocument
    Set pMap = pMxDoc.FocusMap
    
    'Get the editor
    Set pEditor = Application.FindExtensionByName("ESRI Object Editor")
    
    'QI for Attribute Transfer Type and get IAttributeTransfer
    Set pAttTransType = pEditor
    Set pAttTrans = pAttTransType.AttributeTransfer
    
    'QI for default settings and return source/target layers
    Set pATDS = pAttTrans
    Set pSourceFeatLyr = ReturnLayer(pMap, pATDS.SourceName)
    
    'If no mapping set, pSourceFeatLyr will be nothing (null sourcename) so bail
    If pSourceFeatLyr Is Nothing Then
        MsgBox "Attribute Transfer field mapping not set"
        Exit Sub
    End If
    
    'Get the fieldmap for the source layer
    Set pFieldMap = pAttTrans.FindFieldMap(pSourceFeatLyr.FeatureClass, Nothing)
    
    'If fieldmap is nothing then warn user
    If pFieldMap Is Nothing Then
        MsgBox "Attribute Transfer field mapping not set"
        Exit Sub
    End If
    
    'get target feature layer
    Set pTargetFeatLyr = ReturnLayer(pMap, pATDS.TargetName)
    
    'Check if source and target have same geometry type
    If Not (pSourceFeatLyr.FeatureClass.ShapeType = pTargetFeatLyr.FeatureClass.ShapeType) Then
        MsgBox "Source and Target Layer geometries do not match", vbExclamation
        Exit Sub
    End If
    
    
    'Enumerate through each selected feature (source)
    Set pEnumFeat = pEditor.EditSelection
    pEnumFeat.Reset
    Set pSourceFeature = pEnumFeat.Next
    
    pEditor.StartOperation
    
    Do Until pSourceFeature Is Nothing
        
        'Create a new feature in the target
        Set pTargetFeature = pTargetFeatLyr.FeatureClass.CreateFeature
        Set pTargetFeature.Shape = pSourceFeature.ShapeCopy
        pTargetFeature.Store
        
        'Transfer the attributes
        If Not (pTargetFeature Is Nothing) Then
            'Transfer attributes to the new target feature
            pAttTrans.Transfer pFieldMap, pSourceFeature, pTargetFeature, bATSucess
            'Debug.Print bATSucess
        End If
        
        Set pSourceFeature = pEnumFeat.Next
    Loop
    
    pEditor.StopOperation "PUT"
    
End Sub


Private Function ReturnLayer(pMap As IMap, sLayerName As String) As ILayer
    
    'Find a layer in a map document
    'Return the layer or nothing if not found
    
    Dim pEnumLayers As IEnumLayer
    Dim pLayer As ILayer
    
    Set pEnumLayers = pMap.Layers(Nothing, True)
    pEnumLayers.Reset
    Set pLayer = pEnumLayers.Next
    
    Set ReturnLayer = Nothing
    
    Do Until pLayer Is Nothing
        If pLayer.Name = sLayerName Then
            Set ReturnLayer = pLayer
            Exit Do
        End If
        Set pLayer = pEnumLayers.Next
    Loop
    
End Function





Additional Requirements
  • An Edit Session.