Attribute Transfer Mapping

Discussion created by a_inferno3 on Jul 28, 2011
Good day,

I have found a code to perform attribute mapping, but since i am very new in programming, is there a way to hard code the code so that i can specify the layer and field in the code..?

Below is the code..


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
    Set pSourceFeature = pEnumFeat.Next
    Do Until pSourceFeature Is Nothing
        'Create a new feature in the target
        Set pTargetFeature = pTargetFeatLyr.FeatureClass.CreateFeature
        Set pTargetFeature.Shape = pSourceFeature.ShapeCopy
        '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
    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)
    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
End Function


any help will do.
Thank you in advance