Good day,
I found a code in this forum where it is for Attribute Transfer Mapping, it is actually to transfer the attribute from a shapefile to another shapfile. But once i implement the code, and click the button, nothing happen. Bellow 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
=====================================
Do I have to change the code to make it work...? any help will do. Thank you in advance
