digitizetinpolygon.cls

arcgis 编程学习事例

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "DigitizeTinPolygon"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True

' Copyright 1995-2004 ESRI

' All rights reserved under the copyright laws of the United States.

' You may freely redistribute and use this sample code, with or without modification.

' Disclaimer: THE SAMPLE CODE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED 
' WARRANTIES, INCLUDING THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 
' FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL ESRI OR 
' CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, 
' OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF 
' SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
' INTERRUPTION) SUSTAINED BY YOU OR A THIRD PARTY, HOWEVER CAUSED AND ON ANY 
' THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ARISING IN ANY 
' WAY OUT OF THE USE OF THIS SAMPLE CODE, EVEN IF ADVISED OF THE POSSIBILITY OF 
' SUCH DAMAGE.

' For additional information contact: Environmental Systems Research Institute, Inc.

' Attn: Contracts Dept.

' 380 New York Street

' Redlands, California, U.S.A. 92373 

' Email: [e-mail]

Option Explicit

Implements ICommand
Implements ITool

Private m_pApp As IApplication
Private m_pActiveView As IActiveView
Private m_pDispTrans As IDisplayTransformation
Private m_pDispFeedback As IDisplayFeedback
Private m_pNewPolyFeedback As INewPolygonFeedback

Private m_bFeedback_Start As Boolean
Private m_lCursor As esrisystem.OLE_HANDLE

Private m_pTinFeatureEdit As ITinFeatureEdit
Private m_pFeaturePC As IPointCollection

Private m_bStateOK As Boolean

Private Sub FreeVariables()
  Set m_pActiveView = Nothing
  Set m_pDispTrans = Nothing
  Set m_pDispFeedback = Nothing
  Set m_pNewPolyFeedback = Nothing
  Set m_pTinFeatureEdit = Nothing
  Set m_pFeaturePC = Nothing
End Sub

Private Sub Class_Terminate()
  FreeVariables
  Set m_pApp = Nothing
End Sub

Private Property Get ICommand_Bitmap() As esrisystem.OLE_HANDLE
  ICommand_Bitmap = frmDigitizeTinPolygon.Command1.Picture
End Property

Private Property Get ICommand_Caption() As String
  ICommand_Caption = "Digitize TIN Polygon Tool"
End Property

Private Property Get ICommand_Category() As String
  ICommand_Category = "3D TIN Editing Samples"
End Property

Private Property Get ICommand_Checked() As Boolean

End Property

Private Property Get ICommand_Enabled() As Boolean
  On Error GoTo EH
  
  Dim pSurf As ISurface
  Set pSurf = miscUtil.GetCurrentSurface(m_pApp)
  If (Not pSurf Is Nothing) Then
    If (TypeOf pSurf Is ITinEdit) Then
      Dim pTE As ITinEdit
      Set pTE = pSurf
      If (pTE.IsInEditMode) Then
        ICommand_Enabled = True
        Exit Property
      End If
    End If
  End If
  ' In case user clicks command to stop editing while this tool is active
  If (frmDigitizeTinPolygon.Visible = True) Then
    frmDigitizeTinPolygon.Hide
  End If
  ICommand_Enabled = False
  Exit Property
EH:
  ICommand_Enabled = False
End Property

Private Property Get ICommand_HelpContextID() As Long

End Property

Private Property Get ICommand_HelpFile() As String

End Property

Private Property Get ICommand_Message() As String
  ICommand_Message = "Adds a line to a TIN"
End Property

Private Property Get ICommand_Name() As String
  ICommand_Name = "SurfaceAnalysisDigitizeTinPolygon"
End Property

Private Sub ICommand_OnClick()
  Dim pMxDoc As IMxDocument
  Set pMxDoc = m_pApp.Document
  
  Set m_pActiveView = pMxDoc.ActiveView
      
  Set m_pDispTrans = m_pActiveView.ScreenDisplay.DisplayTransformation

  m_bFeedback_Start = False
  
  Set m_pTinFeatureEdit = miscUtil.GetCurrentSurface(m_pApp)
  
  m_lCursor = frmDigitizeTinPolygon.cmdCross.MouseIcon
  
  frmDigitizeTinPolygon.Init miscUtil.GetCurrentSurface(m_pApp)
  
  Dim lRes As Long
  lRes = ShowWindow(frmDigitizeTinPolygon.hwnd, SW_SHOWNORMAL)
End Sub

Private Sub ICommand_OnCreate(ByVal hook As Object)
  Set m_pApp = hook
End Sub

Private Property Get ICommand_Tooltip() As String
  ICommand_Tooltip = "Add TIN Polygon"
End Property

Private Property Get ITool_Cursor() As esrisystem.OLE_HANDLE
  ITool_Cursor = m_lCursor
End Property

Private Function ITool_Deactivate() As Boolean
  frmDigitizeTinPolygon.Hide
  FreeVariables
  ITool_Deactivate = True
End Function

Private Function ITool_OnContextMenu(ByVal X As Long, ByVal Y As Long) As Boolean

End Function

Private Sub ITool_OnDblClick()
  On Error GoTo EH:
  Dim pPolygon As IPolygon
  Set pPolygon = m_pNewPolyFeedback.Stop
  Set pPolygon.SpatialReference = m_pActiveView.FocusMap.SpatialReference
  m_bFeedback_Start = False
  Set m_pFeaturePC = Nothing
  
  If (Not pPolygon Is Nothing) Then
    If (frmDigitizeTinPolygon.DetectConflicts) Then
      If (Not m_bStateOK) Then
        Beep
        Exit Sub
      End If
    End If
        
    Dim pSurf As ISurface
    Set pSurf = m_pTinFeatureEdit
    Dim pTinEdit As ITinEdit
    Set pTinEdit = pSurf
    Dim lZSource As Long
    lZSource = frmDigitizeTinPolygon.GetHeightSource
    
    ' 1=variable, 2=maxz, 3=minz, 4=specified
    If (lZSource = 2 Or lZSource = 3) Then
      Dim pPolyZ As IPolygon
      pSurf.InterpolateShape pPolygon, pPolyZ  ' need to find the z range on surface
      Dim pEnv As IEnvelope
      Set pEnv = pPolyZ.Envelope
      If (lZSource = 2) Then
        Dim dZ As Double
        dZ = pEnv.zmax
      Else
        dZ = pEnv.zmin
      End If
    End If
    
    Dim lTag As Long
    
    Dim lSFType As esriTinSurfaceType
    lSFType = frmDigitizeTinPolygon.GetSFType
        
    ' For Replace polygons, if an offset is provided that means the surface along the
    ' digitized polygon boundary should be 'locked' in place by first adding the poly
    ' as a zless feature. The poly is then buffered inward by the specified offset
    ' and added using the replace height value.
    If ((lSFType = esriTinHardReplace) Or (lSFType = esriTinSoftReplace)) Then
      Dim dOffset As Double
      dOffset = frmDigitizeTinPolygon.GetBufOffset * -1
      If (dOffset <> 0) Then
        pSurf.InterpolateShape pPolygon, pPolyZ
        If (Not pPolyZ Is Nothing) Then
          Dim pTopo As ITopologicalOperator
          Set pTopo = pPolyZ
          Set pPolygon = pTopo.Buffer(dOffset)
          pTinEdit.AddShapeZ pPolyZ, esriTinHardLine, 0
        Else
          Err.Raise -1, "OnDblClick", "Polygon is outside the interpolation zone of the TIN. Unable to use offset option."
        End If
      End If
    End If
    
    If (lZSource = 1) Then ' height variable on surface
      pTinEdit.AddShape pPolygon, lSFType, lTag
    Else
      If (lZSource = 4) Then ' specified height
        dZ = frmDigitizeTinPolygon.GetHeight
      End If                 ' zmin/zmax
      pTinEdit.AddShape pPolygon, lSFType, lTag, dZ
    End If
      
    Dim pLayer As ILayer
    Set pLayer = miscUtil.GetCurrentSurfaceLayer(m_pApp)
    
    Dim bTOCModified As Boolean
    bTOCModified = False
    
    If (tinUtil.FindTinRenderer(pLayer, "Edge types") = -1) Then
      tinUtil.AddTinRenderer pLayer, "TINBREAKLINERENDERER", "Edge type"
      bTOCModified = True
    End If
    
    If (tinUtil.FindTinRenderer(pLayer, "Elevation") = -1) Then
      tinUtil.AddTinRenderer pLayer, "TinElevationRenderer", "Elevation"
      bTOCModified = True
    End If
    
    If (bTOCModified) Then
      If (TypeOf m_pApp Is IMxApplication) Then
        Dim pMxDoc As IMxDocument
        Set pMxDoc = m_pApp.Document
        pMxDoc.CurrentContentsView.Refresh 0 ' 0 seems to work for any position of layer in toc
      End If
    End If
    
    If (lZSource = 4) Then ' user specified, z could be out of legend range
      If (tinUtil.CheckTinLegendZRange(pLayer, dZ)) Then
        If (TypeOf m_pApp Is IMxApplication) Then
          Set pMxDoc = m_pApp.Document
          pMxDoc.CurrentContentsView.Refresh 0 ' 0 seems to work for any position of layer in toc
        End If
      End If
    End If
    
    If (TypeOf m_pApp Is IMxApplication) Then
      Dim pDoc As IMxDocument
      Set pDoc = m_pApp.Document
      pDoc.ActiveView.Refresh
    End If
    
  End If
  
  Exit Sub
  
EH:
  MsgBox "Error on DblClick: " & Err.Description
End Sub

Private Sub ITool_OnKeyDown(ByVal keyCode As Long, ByVal Shift As Long)

End Sub

Private Sub ITool_OnKeyUp(ByVal keyCode As Long, ByVal Shift As Long)

End Sub

Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  Dim pPnt As IPoint
  Set pPnt = m_pDispTrans.ToMapPoint(X, Y)

  If (Button = 1) Then ' add another point
  
    If (Not m_bFeedback_Start) Then
      Set m_pNewPolyFeedback = New NewPolygonFeedback
      Set m_pDispFeedback = m_pNewPolyFeedback
      Set m_pDispFeedback.Display = m_pActiveView.ScreenDisplay
      m_pNewPolyFeedback.Start pPnt
      Set m_pFeaturePC = New Polygon
      m_pFeaturePC.AddPoint pPnt
      m_bFeedback_Start = True
    Else
      If (frmDigitizeTinPolygon.DetectConflicts) Then
        If (Not m_pTinFeatureEdit.CanAddVertex(m_pFeaturePC, pPnt, False, 0)) Then
          m_bStateOK = False
          Beep
          Exit Sub
        Else
          m_bStateOK = True
        End If
      End If
      m_pNewPolyFeedback.AddPoint pPnt
      m_pFeaturePC.AddPoint pPnt
    End If
    
  End If
End Sub

Private Sub ITool_OnMouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  If (m_bFeedback_Start) Then
    Dim pPnt As IPoint
    Set pPnt = m_pDispTrans.ToMapPoint(X, Y)
    m_pDispFeedback.MoveTo pPnt
    If (frmDigitizeTinPolygon.DetectConflicts) Then
      If (Not m_pTinFeatureEdit.CanAddVertex(m_pFeaturePC, pPnt, False, 0)) Then
        m_lCursor = frmDigitizeTinPolygon.cmdNo.MouseIcon
      Else
        m_lCursor = frmDigitizeTinPolygon.cmdCross.MouseIcon
      End If
    Else
      m_lCursor = frmDigitizeTinPolygon.cmdCross.MouseIcon
    End If
  Else
    m_lCursor = frmDigitizeTinPolygon.cmdCross.MouseIcon
  End If
End Sub

Private Sub ITool_OnMouseUp(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)

End Sub

Private Sub ITool_Refresh(ByVal hDC As esrisystem.OLE_HANDLE)

End Sub