Форумы GIS-Lab.info

This script will select the first layer in the TOC, if it is a polyline and has at least one line/record selected, it will add two fields called AriAngle (Arithmetic Rotation aka Polar) and GeoAngle (Geographic Rotation aka North Azimuth) and populate the fields with angles for each selected line/record based upon its from to direction.

CREATED BY: James Zazula, GIS Analyst, City of Barrie, Barrie, Ontario, Canada
CREATED BY: James Zazula, GIS Consultant, GIS North, Barrie, Ontario, Canada
Assistance provided by Kirsten Lowerey, Planning Technician, City of Barrie, Ontario, Canada
If you would like to make improvements to the script, feel free to do so and send me the new script
Created in ArcGIS 8.3, not tested in 9.x

Portion of script based upon ESRI ILINE Example
Portion of script based upon DOUGLAS R. GUESS - LANCASTER COUNTY ASSESSOR/REGISTER OF DEEDS OFFICE

NOTES:
A least one polyline must be selected
The script will only work if the polyline layer is the first layer on the TOC
To calculate the value of PI = 4 * Atn(1)
To convert Angles to Radians (Radians = Angle in Degrees * (PI/180))
To convert Radians to Angles (Angles in Degrees = Radians * (180/PI))

Calculated Angle Arithmetic Angle Geographic Angle
90 90 0
| | |
| | |
180 | | |
-180 ----------- 0 180 ---------- 0 270 ----------- 90
| | |
| | |
| | |
-90 270 180

This script will choose the first layer in the TOC and makes sure that it is a polyline
This script will make sure at least on polyline/record is selected
You do not have to be in edit mode for this script to work, just run the macro FindPolylineAngle

'This routine splits lines at selected points.

Dim pApp As IApplication
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pId As New UID
Dim pEditor As IEditor
Dim pEditorLayers As IEditLayers
Dim pUid As New UID
Dim pEnumLayer As IEnumLayer
Dim pLayer As ILayer
Dim pFLayer As IFeatureLayer
Dim pGeoFLayer As IGeoFeatureLayer
Dim pFSel As IFeatureSelection
Dim pPointCursor As IFeatureCursor
Dim pPointFeature As IFeature
Dim pGeoPointLayer As IGeoFeatureLayer
Dim lPoints As Long

Dim lTotal As Long

Dim pMouseCursor As IMouseCursor

Set pApp = Application
Set pMxDoc = pApp.Document
Set pMap = pMxDoc.FocusMap

'Get a reference to the editor extension
pId = "esriEditor.Editor"
Set pEditor = Application.FindExtensionByCLSID(pId)

'Verify that we are editing
If pEditor.EditState <> esriStateEditing Then
MsgBox "Must be editing."
Exit Sub
End If

'If vbYes <> MsgBox("Are you SURE you wish to continue?", vbYesNo, "Splitting all visible lines based on all selected points...") Then
' Exit Sub
'End If


'ProgressBar
Dim pStepPro As IStepProgressor
Dim pProgressDialogFactory As IProgressDialogFactory
Dim pProgressDialog As IProgressDialog2
Dim pCancelTracker As ITrackCancel

Set pProgressDialogFactory = New ProgressDialogFactory
Set pCancelTracker = New CancelTracker
Set pProgressDialog = pProgressDialogFactory.Create(pCancelTracker, Application.hWnd)
pProgressDialog.CancelEnabled = True

Set pStepPro = pProgressDialog
pProgressDialog.Animation = esriProgressGlobe
pProgressDialog.Title = "Splitting At Selected Points..."

'Create an edit operation enabling undo/redo
pEditor.StartOperation
On Error GoTo AbortEdit1

'Step through each feature layer
pUid = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}" 'GeoFeatureLayer
Set pEnumLayer = pMap.Layers(pUid, True)
pEnumLayer.Reset
Set pLayer = pEnumLayer.Next
Do While Not pLayer Is Nothing
If pLayer.Valid Then

Set pFLayer = pLayer

'Verify that this is a point layer and that it is set to visible in TOC
If pFLayer.FeatureClass.ShapeType = esriGeometryPoint And pFLayer.Visible Then

'Verify that selection exists
Set pFSel = pFLayer
lTotal = pFSel.SelectionSet.Count
If lTotal > 0 Then

pStepPro.MinRange = 1
pStepPro.MaxRange = lTotal
pStepPro.Show

'Initalize counter
lCount = 0
lPoints = 0

'Get selected point features in a cursor
pFSel.SelectionSet.Search Nothing, False, pPointCursor

'Loop through selected points
Set pPointFeature = pPointCursor.NextFeature
Do While Not pPointFeature Is Nothing
lPoints = lPoints + 1
pStepPro.Position = lPoints
pStepPro.Message = "Attempting split at point " & lPoints & " of " & lTotal
'Exit if Cancel pushed
If pCancelTracker.Continue = False Then
pCancelTracker.Cancel
pEditor.StopOperation "Split At Selected Points"
lCount = 0
pMxDoc.ActiveView.Refresh
Exit Sub
End If

'Call routine to split at the point
SplitAtPoint pMap, pPointFeature, pEditor

'Get next point
Set pPointFeature = pPointCursor.NextFeature
Loop
End If
End If
End If


'Get next layer
Set pLayer = pEnumLayer.Next
Loop

'Stop the edit operation (not session - we'll still be editing) and give it a name
pEditor.StopOperation "Split At Selected Points"

pStepPro.Hide
Set pStepPro = Nothing

'Notify user that routine is complete
If lCount > 0 Then
pMxDoc.ActiveView.Refresh
MsgBox "'Split At Selected Points' is complete. Splits occurred at " & lCount & " points."
Else
MsgBox "No lines were split."
End If
lCount = 0
Exit Sub

AbortEdit1:
pEditor.AbortOperation
MsgBox "Error in SplitAtSelectedPoints routine. "
lCount = 0
End Sub
Public Sub AutoSplit(pEditor As IEditor, pPointFeature As IFeature)

'This routine splits a line at one point feature.
'It is intended to be called from the OnCreate editor event.

Dim pMap As IMap
Dim pLineFLayer As IFeatureLayer
Dim iLineDiameterFieldPos As Integer
Dim sPointFC As String
Dim pDataset As IDataset
Dim pPointFC As IFeatureClass
Dim pPointFLayer As IFeatureLayer
Dim pGeoPointLayer As IGeoFeatureLayer
Dim pRR As IRotationRenderer
Dim sPointRotationField As String
Dim bArithmeticAngle As Boolean
Dim iPointRotationFieldPos As Integer

If pPointFeature.Shape.GeometryType <> esriGeometryPoint Then
Debug.Print "AutoSplit: Can't SplitAtPoint with: " & pPointFeature.Shape.GeometryType
Exit Sub
End If

Set pMap = pEditor.Map

'Get the name of the Point FC
Set pPointFC = pPointFeature.Class
Set pDataset = pPointFC
sPointFC = Right(pDataset.BrowseName, Len(pDataset.BrowseName) - InStr(pDataset.BrowseName, "."))

'Get the point feature layer by feature class name
Set pPointFLayer = UTIL_FindFLayerByFCName(pMap, sPointFC)
If pPointFLayer Is Nothing Then
Debug.Print "Could not find " & sPointFC & " feature class."
Exit Sub
End If

'Verify that we have a point feature class
If pPointFLayer.FeatureClass.ShapeType <> esriGeometryPoint Then
Debug.Print "Specified point feature class '" & sPointFC & "' does not contain points."
Exit Sub
End If


SplitAtPoint pMap, pPointFeature, pEditor

End Sub
Public Sub SplitAtPoint(pMap As IMap, pPointFeature As IFeature, pEditor As IEditor)
'This routine is used by both AutoSplit and SplitAtSelectedPoints.
'It contains all of logic for split lines.

On Error GoTo AbortEdit3

Dim pPointFC As IFeatureClass
Dim pSFilter As ISpatialFilter
Dim pLineCursor As IFeatureCursor
Dim pLineFeature As IFeature
Dim pCurve As ICurve
Dim pFeatureEdit As IFeatureEdit
Dim pPoint As esriGeometry.IPoint

Dim i As Integer
Dim pProxop As IProximityOperator
Dim pRelOp As IRelationalOperator
Dim pEditorLayers As IEditLayers
Dim pUid As New UID
Dim pEnumLayer As IEnumLayer
Dim pLayer As ILayer
Dim pFLayer As IFeatureLayer
Dim pGeoFLayer As IGeoFeatureLayer
Dim bFound As Boolean
Dim pPolygon As IPolygon
Dim pTopoOp As ITopologicalOperator
Set pPointFC = pPointFeature.Class
Set pPoint = pPointFeature.Shape

Set pEditorLayers = pEditor

'Create spatial filter to find intersecting features at this given point
Set pSFilter = New SpatialFilter
Set pTopoOp = pPoint
Set pPolygon = pTopoOp.Buffer(dTolerance)
Set pSFilter.Geometry = pPolygon
pSFilter.SpatialRel = esriSpatialRelIntersects

'Step through each feature layer
pUid = "{E156D7E5-22AF-11D3-9F99-00C04F6BC78E}" 'GeoFeatureLayer (correct for 9.0)
Set pEnumLayer = pMap.Layers(pUid, True)
pEnumLayer.Reset
Set pLayer = pEnumLayer.Next

Do While Not pLayer Is Nothing
If pLayer.Valid Then

Set pFLayer = pLayer

'Verify that this is a visible, editable line layer
If pFLayer.FeatureClass.ShapeType = esriGeometryPolyline And pFLayer.Visible And pEditorLayers.IsEditable(pFLayer) Then

'Apply the filter this line layer
pSFilter.GeometryField = pFLayer.FeatureClass.ShapeFieldName
Set pLineCursor = pFLayer.FeatureClass.Search(pSFilter, False)

'Loop through the found lines for this layer
Set pLineFeature = pLineCursor.NextFeature
Do While Not pLineFeature Is Nothing

Set pFeatureEdit = pLineFeature

'Determine if point is at end of this line
Set pRelOp = pPolygon
Set pPolygon = pTopoOp.Buffer(dTolerance)

Set pCurve = pLineFeature.Shape
If Not (pRelOp.Contains(pCurve.FromPoint)) And Not (pRelOp.Contains(pCurve.ToPoint)) Then
pFeatureEdit.Split pPoint
'pLineFeature.Store
lCount = lCount + 1
End If

'Get next line
Set pLineFeature = pLineCursor.NextFeature
Loop
End If
End If

'Get next line layer
Set pLayer = pEnumLayer.Next
Loop


Exit Sub
AbortEdit3:
pEditor.AbortOperation
Debug.Print "Error spliting at point " & pPointFeature.OID
End Sub
Private Function UTIL_FindFLayerByFCName(pMap As IMap, sLayerName As String) As IFeatureLayer
'Find feature layer utility
'Returns the feature layer in the map that matches the given FC name
Dim pEnumLayer As IEnumLayer
Dim pCompositeLayer As ICompositeLayer
Dim i As Integer
Dim pLayer As ILayer
Dim pDataset As IDataset
Dim pFLayer As IFeatureLayer

Set pEnumLayer = pMap.Layers
pEnumLayer.Reset

Set pLayer = pEnumLayer.Next

Do While Not pLayer Is Nothing
If TypeOf pLayer Is ICompositeLayer Then
Set pCompositeLayer = pLayer
For i = 0 To pCompositeLayer.Count - 1
If TypeOf pCompositeLayer.Layer(i) Is IFeatureLayer Then
Set pFLayer = pCompositeLayer.Layer(i)
Set pDataset = pFLayer
If pFLayer.Valid Then
If (UCase(Right(pDataset.BrowseName, Len(pDataset.BrowseName) - InStr(pDataset.BrowseName, ".")))) = UCase(sLayerName) Then
Set UTIL_FindFLayerByFCName = pFLayer
Exit Function
End If
End If
End If
Next i
End If
If Not TypeOf pLayer Is ICompositeLayer And TypeOf pLayer Is IFeatureLayer Then
Set pFLayer = pLayer
Set pDataset = pFLayer
If pFLayer.Valid Then
If (UCase(Right(pDataset.BrowseName, Len(pDataset.BrowseName) - InStr(pDataset.BrowseName, ".")))) = UCase(sLayerName) Then
Set UTIL_FindFLayerByFCName = pFLayer
Exit Function
End If
End If
End If
Set pLayer = pEnumLayer.Next
Loop

End Function