module или form

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_pNewLineFeedback As INewLineFeedback
 
Private m_pTinFeatureEdit As ITinFeatureEdit
Private m_pLinePC As IPointCollection
 
Private m_bFeedback_Start As Boolean
Private m_lCursor As Long
 
Private Sub FreeVariables()
  Set m_pActiveView = Nothing
  Set m_pDispTrans = Nothing
  Set m_pDispFeedback = Nothing
  Set m_pNewLineFeedback = Nothing
  Set m_pTinFeatureEdit = Nothing
  Set m_pLinePC = 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 = frmDigitizeTinLine.Command1.Picture
End Property
 
Private Property Get ICommand_Caption() As String
  ICommand_Caption = "Digitize TIN Line 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 (frmDigitizeTinLine.Visible = True) Then
    frmDigitizeTinLine.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 = "SurfaceAnalysisDigitizeTinLine"
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)
  
  Set m_pLinePC = New Polyline
  
  m_lCursor = frmDigitizeTinLine.cmdCross.MouseIcon
  
  frmDigitizeTinLine.Init miscUtil.GetCurrentSurface(m_pApp)
  
  Dim lRes As Long
  lRes = ShowWindow(frmDigitizeTinLine.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 Line"
End Property
 
Private Property Get ITool_Cursor() As esrisystem.OLE_HANDLE
  ITool_Cursor = m_lCursor
End Property
 
Private Function ITool_Deactivate() As Boolean
  frmDigitizeTinLine.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 pPolyline As IPolyline
  Set pPolyline = m_pNewLineFeedback.Stop
  Set pPolyline.SpatialReference = m_pActiveView.FocusMap.SpatialReference
  m_bFeedback_Start = False
  
  If (Not pPolyline Is Nothing) Then
    Dim pLayer As ILayer
    Set pLayer = miscUtil.GetCurrentSurfaceLayer(m_pApp)
    
    Dim bTOCModified As Boolean
    bTOCModified = False
    
    Dim pSurf As ISurface
    Set pSurf = m_pTinFeatureEdit
    
    Dim pTinEdit As ITinEdit
    Set pTinEdit = pSurf
    
    Dim lSFType As esriTinSurfaceType
    lSFType = frmDigitizeTinLine.GetSFType
    
    Dim lZSource As Long
    lZSource = frmDigitizeTinLine.GetHeightSource
    Select Case lZSource
      Case 1
        pTinEdit.AddShape pPolyline, lSFType, 0
      Case 2
        Dim pPolyZ As IPolyline
        pSurf.InterpolateShape pPolyline, pPolyZ
        Dim pEnv As IEnvelope
        Set pEnv = pPolyZ.Envelope
        pTinEdit.AddShape pPolyline, lSFType, 0, pEnv.zmax
      Case 3
        pSurf.InterpolateShape pPolyline, pPolyZ
        Set pEnv = pPolyZ.Envelope
        pTinEdit.AddShape pPolyline, lSFType, 0, pEnv.zmin
      Case 4
        Dim dZ As Double
        dZ = frmDigitizeTinLine.GetHeight
        pTinEdit.AddShape pPolyline, lSFType, 0, dZ
        
        If (tinUtil.FindTinRenderer(pLayer, "Elevation") <> -1) Then
          bTOCModified = tinUtil.CheckTinLegendZRange(pLayer, dZ)
        End If
    End Select
            
    If (tinUtil.FindTinRenderer(pLayer, "Edge types") = -1) Then
      tinUtil.AddTinRenderer pLayer, "TinBreaklineRenderer", "Edge types"
      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 (TypeOf m_pApp Is IMxApplication) Then
      Dim pDoc As IMxDocument
      Set pDoc = m_pApp.Document
      pDoc.ActiveView.Refresh
      'pActiveView.PartialRefresh esriDPGeography, pLayer, pActiveView.Extent
    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 (frmDigitizeTinLine.chkSnap.Value = vbChecked) Then
    Dim pTin As ITinAdvanced
    Set pTin = m_pTinFeatureEdit
    
    Dim pNode As ITinNode
    Set pNode = New TinNode
    
    Dim dDist As Double
    
    pTin.QueryNearestNode pPnt, pNode, dDist
    If (dDist < CDbl(frmDigitizeTinLine.txtSnap)) Then
      pNode.QueryAsPoint pPnt
    End If
  End If
  
  If (Button = 1) Then ' add another point
  
    If (Not m_bFeedback_Start) Then
      Set m_pNewLineFeedback = New NewLineFeedback
      Set m_pDispFeedback = m_pNewLineFeedback
      Set m_pDispFeedback.Display = m_pActiveView.ScreenDisplay
      m_pNewLineFeedback.Start pPnt
      m_pLinePC.AddPoint pPnt
      m_bFeedback_Start = True
    Else
      m_pNewLineFeedback.AddPoint pPnt
      m_pLinePC.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 (frmDigitizeTinLine.DetectConflicts) Then
      If (Not m_pTinFeatureEdit.CanAddVertex(m_pLinePC, pPnt, False, 0)) Then
        m_lCursor = frmDigitizeTinLine.cmdNo.MouseIcon
      Else
        m_lCursor = frmDigitizeTinLine.cmdCross.MouseIcon
      End If
    Else
      m_lCursor = frmDigitizeTinLine.cmdCross.MouseIcon
    End If
  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