Wednesday, October 11, 2006

Code Snippets

posted by Jay S @ 9:48 AM   4 Comments

4 Comments:

At 1:37 PM , Anonymous Anonymous said...

Private Function IGxObjectFilter_CanChooseObject(ByVal Object As esriCore.IGxObject, DblClickResult As esriDoubleClickResult) As Boolean
' This filter selects for geometric networks only.
Dim pName As IName
Dim strProgID As String
Dim pWkspName As IWorkspaceName
Dim pDSName As IDatasetName
IGxObjectFilter_CanChooseObject = False
DblClickResult = esriDCRDefault

Set pName = Object.InternalObjectName
If TypeOf pName Is IGeometricNetworkName And m_GDBType = GeometricNetwork Then
Set pDSName = pName
Set pWkspName = pDSName.WorkspaceName
strProgID = pWkspName.WorkspaceFactoryProgID
If InStr(1, strProgID, "AccessWorkspaceFactory", vbTextCompare) > 0 Or _
InStr(1, strProgID, "SDEWorkspaceFactory", vbTextCompare) Then
IGxObjectFilter_CanChooseObject = True
DblClickResult = esriDCRChooseAndDismiss
End If
End If

End Function


Private Function IGxObjectFilter_CanDisplayObject(ByVal Object As esriCore.IGxObject) As Boolean
' This filter selects for GDB workspaces, GDB feature datasets, GDB geometric networks.
Dim pName As IName
Dim strProgID As String
Dim pWkspName As IWorkspaceName
Dim pDSName As IDatasetName
IGxObjectFilter_CanDisplayObject = False

'Display all Standard Folders and Disk Connections and Databases
'These are required to be displayed to navigate.
If TypeOf Object Is IGxFolder Then
IGxObjectFilter_CanDisplayObject = True
Exit Function
ElseIf TypeOf Object Is IGxDiskConnection Then
IGxObjectFilter_CanDisplayObject = True
Exit Function
ElseIf TypeOf Object Is IGxDatabase Then
IGxObjectFilter_CanDisplayObject = True
Exit Function
ElseIf TypeOf Object Is IGxRemoteDatabaseFolder Then ' Database connections
IGxObjectFilter_CanDisplayObject = True
Exit Function
ElseIf TypeOf Object Is IGxNewDatabase Then ' SDE connection shortcut
IGxObjectFilter_CanDisplayObject = True
Exit Function
End If

Set pName = Object.InternalObjectName
If Not pName Is Nothing Then
If (TypeOf pName Is IFeatureDatasetName Or TypeOf pName Is IGeometricNetworkName) And (m_GDBType = FeatureDataset Or m_GDBType = GeometricNetwork) Then
Set pDSName = pName
Set pWkspName = pDSName.WorkspaceName
strProgID = pWkspName.WorkspaceFactoryProgID
Else
Exit Function
End If
End If

If InStr(1, strProgID, "AccessWorkspaceFactory", vbTextCompare) > 0 Or _
InStr(1, strProgID, "SDEWorkspaceFactory", vbTextCompare) Then
IGxObjectFilter_CanDisplayObject = True
End If
End Function

>>>>>>>>>>>>>>>>

Option Explicit

Private m_pApp As esriFramework.IApplication
Private m_pEditor As esriEditor.IEditor
Private m_pDoc As esriArcMapUI.IMxDocument
Private m_pContents As esriArcMapUI.IContentsView
Private m_pFLayer As esriCarto.IFeatureLayer
Private m_pFClass As esriGeoDatabase.IFeatureClass
Private m_pSelFeatClass As esriGeoDatabase.IFeatureClass
Private m_pNetClass As esriGeoDatabase.INetworkClass

Implements ICommand

Private Property Get ICommand_Enabled() As Boolean

Dim vSelItem As Variant
Set m_pContents = m_pDoc.CurrentContentsView

If IsNull(m_pContents.SelectedItem) Then
ICommand_Enabled = False
ElseIf Not m_pEditor.EditState = esriStateEditing Then
ICommand_Enabled = False
Else
Set vSelItem = m_pContents.SelectedItem
If TypeOf vSelItem Is esriCarto.IFeatureLayer Then
Set m_pFLayer = vSelItem
Set m_pSelFeatClass = m_pFLayer.FeatureClass
If TypeOf m_pSelFeatClass Is INetworkClass Then
ICommand_Enabled = True
Set m_pNetClass = m_pSelFeatClass 'QI
End If
End If
End If

End Property

Private Property Get ICommand_Checked() As Boolean

ICommand_Checked = False

End Property

Private Property Get ICommand_Name() As String

ICommand_Name = "Developer Samples_Delete Network Elements"

End Property

Private Property Get ICommand_Caption() As String

ICommand_Caption = "Delete Network Elements"

End Property

Private Property Get ICommand_Tooltip() As String

ICommand_Tooltip = "Delete Network Elements"

End Property

Private Property Get ICommand_Message() As String

ICommand_Message = "Deletes the network elements associated with the selected network features"

End Property

Private Property Get ICommand_HelpFile() As String

ICommand_HelpFile = ""

End Property

Private Property Get ICommand_HelpContextID() As Long

ICommand_HelpContextID = 0

End Property

Private Property Get ICommand_Bitmap() As esriSystem.OLE_HANDLE

' TODO: Add your implementation here

End Property

Private Property Get ICommand_Category() As String

ICommand_Category = "Developer Samples"

End Property

Private Sub ICommand_OnCreate(ByVal hook As Object)

Dim pUID As New UID
pUID = "esriEditor.editor"

Set m_pApp = hook
Set m_pDoc = m_pApp.Document
Set m_pEditor = m_pApp.FindExtensionByCLSID(pUID)

End Sub

Private Sub ICommand_OnClick()

On Error GoTo ErrorHandler

Dim pFeatureLayer As esriCarto.IFeatureLayer
Dim pFeatureClass As esriGeoDatabase.IFeatureClass
Dim pFeatureSelection As esriCarto.IFeatureSelection
Dim pLayer As esriCarto.ILayer
Dim pDataset As esriGeoDatabase.IDataset
Dim pSelection As esriCarto.ISelection
Dim pSelectionSet As esriGeoDatabase.ISelectionSet
Dim pSelectionSets As esriSystem.ISet
Dim pGN As esriGeoDatabase.IGeometricNetwork
Dim pGNErrorDetection As esriGeoDatabase.IGeometricNetworkErrorDetection

Dim layerCount As Long
Dim i As Long

'Create the new set of selection sets to hold the invalid features
Set pSelectionSets = New esriSystem.Set

layerCount = m_pDoc.FocusMap.layerCount

For i = 0 To layerCount - 1
Set pLayer = m_pDoc.FocusMap.Layer(i)

If TypeOf pLayer Is IFeatureLayer Then
Set pFeatureLayer = pLayer
Set pFeatureSelection = pFeatureLayer
Set pFeatureClass = pFeatureLayer.FeatureClass

If TypeOf pFeatureClass Is INetworkClass Then
Set pSelectionSet = pFeatureSelection.SelectionSet
If Not pSelectionSet.Count = 0 Then pSelectionSets.Add pSelectionSet
End If
End If
Next i

'If there were no selected features, then just exit
If pSelectionSets.Count = 0 Then Exit Sub
m_pEditor.StartOperation

'Get the network of the selected network class
'and delete the network elements of the selected features
Set pGN = m_pNetClass.GeometricNetwork
Set pGNErrorDetection = pGN

pGNErrorDetection.DeleteNetworkElements pSelectionSets

m_pEditor.StopOperation "Delete Network Elements"
MsgBox "Network elements deleted"

Exit Sub
ErrorHandler:
m_pEditor.AbortOperation
MsgBox "Error Deleting Network Elements" & vbCrLf & "Operation Aborted"
End Sub

 
At 3:59 PM , Anonymous Anonymous said...

public double GetAngle(IPoint fromPoint, IPoint thruPoint, IPoint toPoint)
{
try
{
IConstructAngle constAngle = new GeometryEnvironmentClass();

double OutAngle = 0;
OutAngle = constAngle.ConstructThreePoint(fromPoint, thruPoint, toPoint);

}
catch(Exception objException)
{
Debug.WriteLine("An error has occured: GetAngle" + objException.Message);
}
}

 
At 4:29 PM , Anonymous Anonymous said...

Re: Calculating the angle between two lines
Author Kirk Kuykendall
Date Mar 17, 2003
Message The IConstructAngle interface is handy for this sort of thing. Code below loops through each selected polyline in layer(0) and for point of intersection with a polyline in layer(1) it writes the angle of intersection.

kkeywords iconstructangle
Option Explicit
Sub Test()
' writes angles of intersection between each
' selected polyline in layer(0) with each polyline
' in layer(1) onto the screendisplay
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument

Dim pAV As IActiveView
Set pAV = pMxDoc.FocusMap

Dim pFSel As IFeatureSelection
Set pFSel = pMxDoc.FocusMap.Layer(0)
If pFSel.SelectionSet.Count = 0 Then
MsgBox "nothing selected"
Exit Sub
End If

Dim pFCur As IFeatureCursor
pFSel.SelectionSet.Search Nothing, False, pFCur
Dim pFeat As IFeature
Set pFeat = pFCur.NextFeature
Do Until pFeat Is Nothing
DrawAngles pAV.ScreenDisplay, _
pFeat.ShapeCopy, _
pMxDoc.FocusMap.Layer(1)
Set pFeat = pFCur.NextFeature
Loop
End Sub

Sub DrawAngles(pDisp As IScreenDisplay, _
pPolyline As IPolyline, _
pFLayer As IFeatureLayer)

Dim pSF As ISpatialFilter
Set pSF = New SpatialFilter
Set pSF.Geometry = pPolyline
pSF.SpatialRel = esriSpatialRelIntersects

Dim pFCur As IFeatureCursor
Set pFCur = pFLayer.FeatureClass.Search(pSF, False)

Dim pTopoOp As ITopologicalOperator
Set pTopoOp = pPolyline
With pDisp
.StartDrawing .hDC, esriNoScreenCache
.SetSymbol New SimpleLineSymbol
.DrawPolyline pPolyline
.SetSymbol New TextSymbol
Dim pFeat As IFeature
Set pFeat = pFCur.NextFeature
Do Until pFeat Is Nothing
Dim dAngles() As Double
Dim pPointColl As IPointCollection
GetAngles pPolyline, pFeat.ShapeCopy, dAngles, _
pPointColl
Dim l As Long
For l = 0 To pPointColl.PointCount - 1
.DrawText pPointColl.Point(l), _
Format(dAngles(l), "00")
Next l
Set pFeat = pFCur.NextFeature
Loop
.FinishDrawing
End With

End Sub

Sub GetAngles(pPolyline1 As IPolyline, pPolyline2 As IPolyline, _
dAngles() As Double, ByRef pMP As IMultipoint)
' create a multipoint of intersections between
' pPolyline1 and pPolyline2, and an array of
' intersection angles
Dim pTopoOp As ITopologicalOperator
Set pTopoOp = pPolyline1

Set pMP = pTopoOp.Intersect(pPolyline2, _
esriGeometry0Dimension)
Dim pPointColl As IPointCollection
Set pPointColl = pMP

ReDim dAngles(pPointColl.PointCount - 1)
Dim l As Long
For l = 0 To pPointColl.PointCount - 1
Dim pFrom As IPoint, pThru As IPoint, pTo As IPoint
Set pThru = pPointColl.Point(l)
Set pFrom = GetNormal(pPolyline1, pThru, 1#)
Set pTo = GetNormal(pPolyline2, pThru, 1#)
dAngles(l) = GetAngle(pFrom, pThru, pTo)
Next l
End Sub

Function GetNormal(pCurve As ICurve, pPoint As IPoint, _
dOff As Double) As IPoint
Dim pOutPoint As IPoint, dAlong As Double
Dim dFrom As Double, bRight As Boolean
Set pOutPoint = New Point
pCurve.QueryPointAndDistance esriNoExtension, pPoint, True, _
pOutPoint, dAlong, dFrom, bRight
Dim pLine As ILine
Set pLine = New esriCore.Line
pCurve.QueryNormal esriNoExtension, dAlong, True, dOff, pLine
Set GetNormal = pLine.ToPoint
End Function

Function GetAngle(pFrom As IPoint, _
pThru As IPoint, _
pTo As IPoint) As Double
Dim pConstAngle As IConstructAngle
Set pConstAngle = New GeometryEnvironment
GetAngle = pConstAngle.ConstructThreePoint(pFrom, pThru, pTo)
Dim PI As Double
PI = Atn(1#) * 4
GetAngle = (GetAngle * 360) / (2# * PI)
End Function

 
At 10:37 AM , Anonymous Anonymous said...

Function GetSubCurve(pPoint1 As IPoint, _
pPoint2 As IPoint, _
pCurve As ICurve) As ICurve

Dim pOutPoint As IPoint, d1 As Double, dFrom As Double, _
bRight As Boolean, d2 As Double

pCurve.QueryPointAndDistance esriNoExtension, pPoint1, True, _
pOutPoint, d1, dFrom, bRight
pCurve.QueryPointAndDistance esriNoExtension, pPoint2, True, _
pOutPoint, d2, dFrom, bRight

Dim pOutCurve As ICurve
pCurve.GetSubCurve d1, d2, True, pOutCurve
Set GetSubCurve = pOutCurve
End Function

 

Post a Comment

Subscribe to Post Comments [Atom]

<< Home