' Copyright 2008 ESRI
'
' All rights reserved under the copyright laws of the United States
' and applicable international laws, treaties, and conventions.
'
' You may freely redistribute and use this sample code, with or
' without modification, provided you include the original copyright
' notice and use restrictions.
'
' See use restrictions at <your ArcGIS install location>/developerkit/userestrictions.txt.
'
Option Explicit
Dim m_pApp As IApplication
Dim m_pEditor As IEditor
Dim m_pEditLayers As IEditLayers
Dim m_pFC As IFeatureClass 'Feature Class of the selected features
Dim m_lSubtype As Long
Dim m_colFeatures As Collection 'Collection of features selected
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub cmdCancel_Click()
Me.Hide
Unload Me
End Sub
Private Sub cmdOK_Click()
Dim pFCC As IFeatureClassContainer
Dim pEnumFeature As IEnumFeature
Dim pAttributeFeature As IFeature
Dim pSubtypes As ISubtypes
Dim colAttributes As Collection
Dim pCurFeature As IFeature 'Currently selected feature
Dim pNewFeature As IFeature 'New, merged feature
Dim lGTotalVal As Long
Dim lCount As Long 'Count of features
Dim pNFC As INetworkClass
Dim pCurGeom As IGeometry 'Geom of the current feature
Dim pTmpGeom As IGeometry
Dim pOutputGeometry As IGeometry
Dim pTopoOperator As ITopologicalOperator 'Used to union the extent of the features
Dim pOutRSType As IRowSubtypes
Dim pFlds As IFields
Dim pFld As IField
Dim pDomain As IDomain
Dim pGeomColl As IGeometryCollection
Dim ErrCode As Long
Dim lSubTypeCode As Long
Dim iSelCount As Integer
Dim strOID As String
Dim i, j As Integer
Screen.MousePointer = vbHourglass
'The Next button doesn't get enabled until at least 1 FC is selected, but just in case...
If lstMergeFeatures.ListCount = 0 Then
MsgBox "Must have one feature selected before continuing"
Exit Sub
End If
'For Next loop which iterates through the array populating colSelClasses
'This is for when I implement selecting multiple feature classes from the listbox....
For i = 0 To lstMergeFeatures.ListCount - 1
If lstMergeFeatures.Selected(i) Then
strOID = lstMergeFeatures.List(i)
Exit For
End If
Next i
'Get the field values of the selected feature for use later
Set pAttributeFeature = m_colFeatures.Item(strOID)
Set colAttributes = New Collection
For i = 1 To pAttributeFeature.Fields.FieldCount
colAttributes.Add pAttributeFeature.Value(i - 1)
Next i
'If the features being merged and the target layer are the same FC and if that FC has subtypes, get the subtype code of the selected feature or target layer
'If not, get the default
Set pSubtypes = m_pFC
If pSubtypes.HasSubtype Then
lSubTypeCode = m_lSubtype
End If
'start edit operation
m_pEditor.StartOperation
ErrCode = 1
Set pEnumFeature = m_pEditor.EditSelection
pEnumFeature.Reset
'create a new feature to be the merge feature
Set pNFC = m_pFC 'QI
Set pNewFeature = pNFC.CreateFeature 'Create the new feature
'create the new geometry.
'initialize the default values for the new feature
Set pOutRSType = pNewFeature 'Set the RowSubtypes to the NewFeature
If lSubTypeCode <> 0 Then
pOutRSType.SubtypeCode = lSubTypeCode 'If there's a subtype code, set it
End If
pOutRSType.InitDefaultValues 'Init the Default values for the feature
'get the first feature
Set pCurFeature = pEnumFeature.Next
Set pFlds = m_pFC.Fields
'Loop until we've gone through all the selected features (pCurFeature)
lCount = 1
Do
'get the geometry of the current feature, if it's the first feature, set it to pTmpGeom
'Otherwise, pTmpGeom is already set so Union the Geom of this feature with pTmpGeom
'And set that equal to the new pTmpGeom......
Set pCurGeom = pCurFeature.ShapeCopy
If lCount = 1 Then
Set pTmpGeom = pCurGeom
Else
Set pTopoOperator = pTmpGeom
Set pOutputGeometry = pTopoOperator.Union(pCurGeom)
Set pTmpGeom = pOutputGeometry
End If
'now go through each field, if it has a domain associated with it, then evaluate the merge policy...
'If not domain, then grab the value from the selected feature
Set pSubtypes = m_pFC
For j = 0 To pFlds.FieldCount - 1
Set pFld = pFlds.Field(j)
Set pDomain = pSubtypes.Domain(lSubTypeCode, pFld.Name)
If Not pDomain Is Nothing And Not (pFld.DefaultValue = Null) Then
Debug.Print pFld.Name
Select Case pDomain.MergePolicy
Case esriMPTSumValues 'Sum values
If lCount = 1 Then
pNewFeature.Value(j) = pCurFeature.Value(j)
Else
pNewFeature.Value(j) = pNewFeature.Value(j) + pCurFeature.Value(j)
End If
Case esriMPTAreaWeighted 'Area/length weighted average
If lCount = 1 Then
pNewFeature.Value(j) = pCurFeature.Value(j) * (getGeomVal(pCurFeature) / lGTotalVal)
Else
pNewFeature.Value(j) = pNewFeature.Value(j) + (pCurFeature.Value(j) * (getGeomVal(pCurFeature) / lGTotalVal))
End If
End Select 'do not need a case for default value as it is set above
Else
'If this is the first feature we're iterating through, set the values; otherwise we don't need to do this each time
If lCount = 1 Then
'Set the field values from the selected feature; ignore Subtype, non-editable and Shape field
Debug.Print pFld.Name
If pFld.Editable = True And pSubtypes.SubtypeFieldIndex <> j And UCase(m_pFC.ShapeFieldName) <> UCase(pFld.Name) Then
Debug.Print pFld.Name, colAttributes(j + 1)
pNewFeature.Value(j) = colAttributes(j + 1)
End If
End If
End If
Next j
pCurFeature.Delete 'delete the feature
Set pCurFeature = pEnumFeature.Next
lCount = lCount + 1
Loop Until pCurFeature Is Nothing
'Check if the merged geometry is multi-part. If so, raise an error and abort
'Multipart geometries are not supported in the geometric network.
Set pGeomColl = pOutputGeometry
If pGeomColl.GeometryCount > 1 Then
m_pEditor.AbortOperation
MsgBox "Merge operation aborted." & vbCrLf & "Error mergeing features." & vbCrLf & "Multipart edge geometries are not supported, selected features may form multipart feature.", , "Error on Merge Network Features"
Unload Me
Exit Sub
End If
Set pNewFeature.Shape = pOutputGeometry
pNewFeature.Store
Dim pCEF As IComplexEdgeFeature
If m_pFC.FeatureType = esriFTComplexEdge Then
Set pCEF = pNewFeature 'QI
pCEF.ConnectAtIntermediateVertices
End If
'finish edit operation
m_pEditor.StopOperation ("Merge Network Features")
ErrCode = 2
'refresh features
Dim pRefresh As IInvalidArea
Set pRefresh = New InvalidArea
Set pRefresh.Display = m_pEditor.Display
pRefresh.Add pNewFeature
pRefresh.Invalidate -2
'select new feature
Dim pMap As IMap
Set pMap = m_pEditor.Map
pMap.ClearSelection
pMap.SelectFeature FindLayer(pMap), pNewFeature
Unload Me
Exit Sub
ErrHandle:
Select Case ErrCode
Case 0
m_pEditor.AbortOperation
MsgBox "Merge not initiated" & vbCrLf & "Error on collecting geometries of selected features", , "Error with selected features"
Case 1
m_pEditor.AbortOperation
MsgBox "Merge operation aborted." & vbCrLf & "Error mergeing features." & vbCrLf & Err.Number & vbCrLf & Err.Description, , "Error on Merge Network Features"
Case 2
MsgBox "Merge operation completed." & vbCrLf & "Error refreshing the display following merge operation.", , "Error refreshing display"
Case Else
MsgBox "Merge operation completed." & vbCrLf & Err.Number & vbCrLf & Err.Description
End Select
End Sub
Private Sub Form_Load()
Dim pFeature As IFeature
Dim i As Long
'Disable the OK button
Screen.MousePointer = vbDefault
cmdOK.Enabled = False
'For each feature in the collection, add it to the form
For i = 1 To m_colFeatures.Count
Set pFeature = m_colFeatures.Item(i)
Me.lstMergeFeatures.AddItem pFeature.OID
Next i
End Sub
Public Sub ShowModal(ByVal pMergeNetFeats As clsMergeNetFeats)
Set m_pApp = pMergeNetFeats.m_pApp
Set m_pEditor = pMergeNetFeats.m_pEditor
Set m_colFeatures = pMergeNetFeats.m_colFeatures
Set m_pFC = pMergeNetFeats.m_pFC
m_lSubtype = pMergeNetFeats.m_lSubtype
Me.Show vbModal
End Sub
Public Function FindLayer(pMap As IMap) As ILayer
'helper function to find a layer for a feature class
Dim i As Long
Dim pLayer As ILayer
Dim pFeatLayer As IFeatureLayer
For i = 0 To pMap.LayerCount - 1
Set pLayer = pMap.Layer(i)
If TypeOf pLayer Is IFeatureLayer Then
Set pFeatLayer = pLayer
'Check if the layer is valid, ie: it's data source is valid....
If pFeatLayer.Valid Then
If pFeatLayer.FeatureClass.ObjectClassID = m_pFC.ObjectClassID Then
Set pLayer = pFeatLayer
Set FindLayer = pLayer
End If
End If
End If
Next i
End Function
Public Function getGeomVal(pFeature As IFeature) As Double
'helper function to get the area/length/perimeter of a feature
Dim pFC As IFeatureClass
Set pFC = pFeature.Class
Dim pvFlds As IFields
Set pvFlds = pFC.Fields
If pFC.ShapeType = esriGeometryNull Then
getGeomVal = 0
Else
getGeomVal = pFeature.Value(pvFlds.FindField(pFC.LengthField.Name))
End If
End Function
Private Sub lstMergeFeatures_Click()
If lstMergeFeatures.ListCount = 0 Then
cmdOK.Enabled = False
Else
cmdOK.Enabled = True
Dim pMxDoc As IMxDocument
Dim pFeature As IFeature
Dim strOID As String
Dim i As Long
For i = 0 To lstMergeFeatures.ListCount - 1
If lstMergeFeatures.Selected(i) Then
strOID = lstMergeFeatures.List(i)
Exit For
End If
Next i
Set pMxDoc = m_pApp.Document
Set pFeature = m_colFeatures.Item(strOID)
FlashLine pFeature, pMxDoc
End If
End Sub
Private Sub FlashLine(pFeature As IFeature, pMxDoc As IMxDocument)
' Start Drawing on screen
pMxDoc.ActiveView.ScreenDisplay.StartDrawing 0, esriNoScreenCache
Dim pDisplay As IScreenDisplay
Dim pGeometry As IGeometry
Set pDisplay = pMxDoc.ActiveView.ScreenDisplay
Set pGeometry = pFeature.Shape
Dim pLineSymbol As ISimpleLineSymbol
Dim pSymbol As ISymbol
Dim pRgbColor As IRgbColor
Set pLineSymbol = New SimpleLineSymbol
pLineSymbol.Width = 4
Set pRgbColor = New RgbColor
pRgbColor.Green = 128
Set pSymbol = pLineSymbol
pSymbol.ROP2 = esriROPNotXOrPen
pDisplay.SetSymbol pLineSymbol
pDisplay.DrawPolyline pGeometry
Sleep 300
pDisplay.DrawPolyline pGeometry
' Finish drawing on screen
pMxDoc.ActiveView.ScreenDisplay.FinishDrawing
End Sub