settintags.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 = "SetTinTags"
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_pTinFeatureEdit As ITinFeatureEdit

Private m_lCursor As Long

Private Sub FreeVariables()
  Set m_pActiveView = Nothing
  Set m_pDispTrans = Nothing
  Set m_pTinFeatureEdit = 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 = frmSetTinTags.Command1.Picture
End Property

Private Property Get ICommand_Caption() As String
  ICommand_Caption = "Set TIN Tags 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 (TypeOf pSurf Is ITinEdit) Then
    Dim pTinEdit As ITinEdit
    Set pTinEdit = pSurf
    If (pTinEdit.IsInEditMode) Then
      ICommand_Enabled = True
      Exit Sub
    End If
  End If
  
  ' In case user clicks command to stop editing while this tool is active
  If (frmSetTinTags.Visible = True) Then
    frmSetTinTags.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 = "Sets node, edge, and triangle tags"
End Property

Private Property Get ICommand_Name() As String
  ICommand_Name = "SurfaceAnalysisSetTinTags"
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
   
  Dim lRes As Long
  lRes = ShowWindow(frmSetTinTags.hwnd, SW_SHOWNORMAL)
  
  m_lCursor = frmSetTinTags.cmdCross.Picture.Handle
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 = "Set TIN Tags"
End Property

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

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

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

End Function

' TODO - look to see that new tag is in legend and add it if not.
Private Sub ITool_OnDblClick()

  Dim lSelectMethod As Long
  lSelectMethod = frmSetTinTags.GetSelectMethod
  
  If (lSelectMethod = 1) Then ' select by polygon
  
    Dim pTinSel As ITinSelection
    Set pTinSel = miscUtil.GetCurrentSurface(m_pApp)
    
    Dim pTinEdit As ITinEdit
    Set pTinEdit = pTinSel
    
    Dim lElementType As esriTinElementType
    lElementType = frmSetTinTags.GetElementType
    
    Dim lTag As Long
    lTag = frmSetTinTags.GetTagValue
    
    Dim pPolygon As IPolygon
    Set pPolygon = m_pNewPolyFeedback.Stop
    Set pPolygon.SpatialReference = m_pActiveView.FocusMap.SpatialReference
    m_bFeedback_Start = False
  
    If (Not pPolygon Is Nothing) Then
      pTinSel.SelectByArea lElementType, pPolygon, True, False, esriTinSelectionNew
      Dim pEnum As IEnumTinElement
      Set pEnum = pTinSel.GetSelection(lElementType)
      
      Select Case lElementType
        Case esriTinNode
          Dim pElement As ITinElement
          Set pElement = New TinNode
          pEnum.QueryNext pElement
          Do While (Not pElement.IsEmpty)
            pTinEdit.SetTriangleTagValue pElement.index, lTag
            pEnum.QueryNext pElement
          Loop
        Case esriTinEdge
          Set pElement = New TinEdge
          pEnum.QueryNext pElement
          Do While (Not pElement.IsEmpty)
            pTinEdit.SetTriangleTagValue pElement.index, lTag
            pEnum.QueryNext pElement
          Loop
        Case esriTinTriangle
          Set pElement = New TinTriangle
          pEnum.QueryNext pElement
          Do While (Not pElement.IsEmpty)
            pTinEdit.SetTriangleTagValue pElement.index, lTag
            pEnum.QueryNext pElement
          Loop
      End Select
    End If
    
    miscUtil.RedrawLayer m_pApp, miscUtil.GetCurrentSurfaceLayer(m_pApp)
  End If
  
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

' TODO - look to see that new tag is in legend and add it if not.
Private Sub ITool_OnMouseDown(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
  On Error GoTo EH
  
  Dim pPnt As IPoint
  Set pPnt = m_pDispTrans.ToMapPoint(X, Y)
  
  Dim lSelectMethod As Long
  lSelectMethod = frmSetTinTags.GetSelectMethod
  
  Select Case lSelectMethod
    Case 0 ' point
      Dim pTinAdv As ITinAdvanced2
      Set pTinAdv = miscUtil.GetCurrentSurface(m_pApp)
      
      Dim pTinEdit As ITinEdit
      Set pTinEdit = pTinAdv
      
      Dim dDist As Double
      
      Dim lType As esriTinElementType
      lType = frmSetTinTags.GetElementType
      
      Dim lTag As Long
      lTag = frmSetTinTags.GetTagValue
      
      Select Case lType
        Case esriTinNode
          Dim pNode As ITinNode
          Set pNode = New TinNode
          pTinAdv.QueryNearestNode pPnt, pNode, dDist
          pTinEdit.SetNodeTagValue pNode.index, lTag
        Case esriTinEdge
          Dim pEdge As ITinEdge
          Set pEdge = New TinEdge
          pTinAdv.QueryNearestEdge pPnt, pEdge, dDist
          pTinEdit.SetEdgeTagValue pEdge.index, lTag
        Case esriTinTriangle
          Dim lIndex As Long
          lIndex = pTinAdv.FindTriangleIndex(pPnt)
          pTinEdit.SetTriangleTagValue lIndex, lTag
      End Select
        
      ' TODO modify redraw call to support envelope as optional arg
      miscUtil.RedrawLayer m_pApp, miscUtil.GetCurrentSurfaceLayer(m_pApp)
    Case 1 ' polygon
      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
        m_bFeedback_Start = True
      Else
        m_pNewPolyFeedback.AddPoint pPnt
      End If
    Case 2 ' flood fill
      lTag = frmSetTinTags.GetTagValue
      
      Set pTinAdv = miscUtil.GetCurrentSurface(m_pApp)
      
      Dim pSeed As ITinTriangle
      Set pSeed = pTinAdv.FindTriangle(pPnt)
      
      Set pTinEdit = pTinAdv
      pTinEdit.PropagateTriangleTagValue pSeed, lTag, False ' TODO: enhance to support stopping at enforced edges
      
      ' TODO modify redraw call to support envelope as optional arg
      miscUtil.RedrawLayer m_pApp, miscUtil.GetCurrentSurfaceLayer(m_pApp)
  End Select
   
  Exit Sub
EH:
  MsgBox Err.Description, vbCritical, Err.Source
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
  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