a_inferno3

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
    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

==============

any help will do.
Thank you in advance

Outcomes