rotatesymbol.cls

ArcEngine 这是基于AE组件的源代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "RotateSymbol"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Dim m_bTracking As Boolean
Dim m_pRenderer As IRotationRenderer
Dim m_dClosestDist As Double

Private Sub m_pEd_OnCreateFeature(ByVal obj As esriGeoDatabase.IObject)
On Error GoTo ErrHand:
  If m_bTracking Then
    Rotate obj, True
  End If
    
  Exit Sub
ErrHand:
  MsgBox "RotateSymbolOnCreate - " & Err.Description
End Sub

Private Sub Rotate(obj As IObject, bSetToZero As Boolean)
On Error GoTo ErrHand:

  Dim pAddFeature As iFeature
  Dim iLoop As Integer, pField As Long
  Dim pSnapEnv As ISnapEnvironment
  Dim pSnapAgent As IFeatureSnapAgent
  Dim pTempSegment As ISegment, pClosestSegment As ISegment
  Dim pFields As IFields, dAngle As Double
  
  Set pAddFeature = obj
  
  'Figure out what segment we snapped to.
  Set pTempSegment = Nothing
  Set pClosestSegment = Nothing
  Set pSnapEnv = m_pEditor
  m_dClosestDist = 999999999
  For iLoop = 0 To pSnapEnv.SnapAgentCount - 1
    If TypeOf pSnapEnv.SnapAgent(iLoop) Is IFeatureSnapAgent Then
      Set pSnapAgent = pSnapEnv.SnapAgent(iLoop)
      If pSnapAgent.HitType = esriGeometryPartBoundary And _
       (pSnapAgent.FeatureClass.ShapeType = esriGeometryPolyline Or _
       pSnapAgent.FeatureClass.ShapeType = esriGeometryPolygon) Then
        Set pTempSegment = FindClosestSegment(pAddFeature, _
         pSnapEnv.SnapTolerance, pSnapAgent.FeatureCache)
        If Not pTempSegment Is Nothing Then
          Set pClosestSegment = pTempSegment
        Else
        End If
      End If
    End If
  Next iLoop
  
  'Get the angle from the segment we snapped to.
  If Not pClosestSegment Is Nothing Then
    Dim pLine As ILine
    If TypeOf pClosestSegment Is ILine Then
      Set pLine = New esriGeometry.Line
      pLine.PutCoords pClosestSegment.FromPoint, pClosestSegment.ToPoint
    ElseIf TypeOf pClosestSegment Is ICurve Then
      Dim pCurve As ICurve
      Dim pOutPoint As IPoint
      Set pOutPoint = New esriGeometry.Point
      Set pLine = New esriGeometry.Line
      Dim dAlongDist As Double, dFromDist As Double, dLength As Double, bSide As Boolean
      Set pCurve = pClosestSegment
      pCurve.QueryPointAndDistance esriExtendTangents, pAddFeature.Shape, False, pOutPoint, dAlongDist, _
        dFromDist, bSide
      dLength = 1
      pCurve.QueryTangent esriExtendTangents, dAlongDist, False, dLength, pLine
    End If
    'Rotate the symbol to the correct angle
    dAngle = pLine.angle * (180 / 3.14159265358979)
    If m_pRenderer.RotationType = esriRotateSymbolGeographic Then
      dAngle = Abs(dAngle - 360) + 90
    End If
    If dAngle > 360 Then
      dAngle = dAngle - 360
    ElseIf dAngle < 0 Then
      dAngle = dAngle + 360
    End If
  Else
    If bSetToZero Then
      dAngle = 0
    End If
  End If
  
  'Apply the angle we found
  Set pFields = pAddFeature.Fields
  pField = pFields.FindField(m_pRenderer.RotationField)
  pAddFeature.Value(pField) = Round(dAngle, 0)
  
  Exit Sub
  
ErrHand:
  MsgBox "Rotate - " & Err.Description
  Exit Sub
End Sub

Private Sub m_pEd_OnCurrentLayerChanged()
  TrackingCheck
End Sub

Private Function FindClosestSegment(pPtFeature As iFeature, _
 pSnapTolerance As Double, pFeatureCache As IFeatureCache) As ISegment
  Dim pLoop As Integer, pSnapDist As Double, lPart As Long, lSegment As Long
  Dim pGeom As IHitTest, pTempSegment As ISegment
  Dim bSnapFlag As Boolean, pTempPolyline As ISegmentCollection
  Dim pHitPoint As IPoint, bSide As Boolean
  Dim pGeomColl As IGeometryCollection, pTempPolyline2 As ISegmentCollection
  Set pHitPoint = New esriGeometry.Point
  Set pTempSegment = Nothing
  For pLoop = 0 To pFeatureCache.count - 1
    Set pGeom = pFeatureCache.Feature(pLoop).Shape
    bSnapFlag = pGeom.HitTest(pPtFeature.Shape, pSnapTolerance, esriGeometryPartBoundary, _
     pHitPoint, pSnapDist, lPart, lSegment, bSide)
    If bSnapFlag And (pSnapDist < m_dClosestDist) Then
      Set pTempPolyline = pFeatureCache.Feature(pLoop).Shape
      
      Dim pClone As IClone
      If lPart > 0 Then
        Set pGeomColl = pTempPolyline
        Set pTempPolyline2 = pGeomColl.Geometry(lPart)
        Set pClone = pTempPolyline2.Segment(lSegment)
      Else
        Set pClone = pTempPolyline.Segment(lSegment)
      End If
      Set pTempSegment = pClone.Clone
      m_dClosestDist = pSnapDist
    End If
  Next pLoop
  
  Set FindClosestSegment = pTempSegment
End Function

Private Sub m_pMap_ContentsChanged()
  TrackingCheck
End Sub

Private Sub TrackingCheck()
On Error GoTo ErrHand:
  Dim pEdLayer As IEditLayers, pCurLayer As IFeatureLayer
  
  If m_pEditor Is Nothing Then Exit Sub
  If m_pEditor.EditState <> esriStateEditing Then Exit Sub
  
  Set pEdLayer = m_pEditor
  If pEdLayer.currentLayer Is Nothing Then
    m_bTracking = False
    Exit Sub
  End If
  
  Set pCurLayer = pEdLayer.currentLayer
  If Not TypeOf pCurLayer Is IGeoFeatureLayer Then
    m_bTracking = False
    Exit Sub
  End If
  
  Dim pRenderer As IRotationRenderer
  Dim pGeoLayer As IGeoFeatureLayer
  Set pGeoLayer = pCurLayer
  Set pRenderer = pGeoLayer.Renderer
  If pRenderer.RotationField = "" Then
    m_bTracking = False
    Set m_pRenderer = Nothing
  Else
    Set m_pRenderer = pRenderer
    m_bTracking = True
  End If
  
  Exit Sub
  
ErrHand:
  MsgBox "RotateSym-TrackingCheck - " & Err.Description
End Sub