frmtinbuildingburner.frm

arcgis 编程学习事例

    If (radConstHeight.Value = True) Then
      Dim dHeight As Double
      dHeight = CDbl(txtHeight)
      dHeight = dHeight * dZFact
    End If
    
    Dim dBufDist As Double
    dBufDist = CDbl(txtBuffer)
   
    Dim bAssignTags As Boolean
    
    If (chkTags.Value = vbChecked) Then
      bAssignTags = True
    Else
      bAssignTags = False
    End If
    
    ' Set up cancel tracking and progress bar
    Dim pCancel As ITrackCancel
    Set pCancel = New CancelTracker
    pCancel.CancelOnClick = False
    pCancel.CancelOnKeyPress = True
    Dim pProg As IProgressor
    Set pProg = m_pApp.StatusBar.ProgressBar
    pCancel.Progressor = pProg
    m_pApp.StatusBar.ShowProgressBar "Press ESC to cancel...", 0, 100, 1, True
    
    Dim i As Long
    i = 0
    
    Dim lStepFeatures As Long
    lStepFeatures = lFeatureCount / 100
    
    ' Here's the feature loop
    Do While (Not pInFeature Is Nothing)
          
      i = i + 1
            
      If (i = lStepFeatures) Then
        If (Not pCancel.Continue) Then
          Exit Do
        End If
        i = 0
      End If
            
      Dim pPoly As IPolygon
      Set pPoly = pInFeature.Shape
    
      Dim pGeom As IGeometry
      Set pGeom = pPoly
      pGeom.Project pTinSR
      
      Dim lOID As Long
      lOID = pInFeature.Value(lInxOIDField)
      
      m_pApp.StatusBar.ProgressBar.Message = "OID: " & Str(lOID)
              
      ' Interpolate footprint boundary. This is needed to:
      '   - get its z range for evaluation if building height is relative
      '     to base.
      '   - get correct polygon to buffer for rooftop.
      '   - get a 3D shape to add as a footprint, rather than a 2D shape. With
      '     both footprints and rooftops added as 3D shapes we avoid a performance
      '     penalty that exists when switching between these types (implicit
      '     masking/unmasking of 'super' triangles).
      pSurf.InterpolateShape pPoly, pPoly
                                                
      If (Not pPoly Is Nothing) Then ' could be NULL of outside of surface
        
        ' Get Z range information
        Dim pPrintGeom As IGeometry
        Set pPrintGeom = pPoly
        
        Dim pEnv As IEnvelope
        Set pEnv = pPrintGeom.Envelope
      
        Dim zmin As Double
        Dim zmax As Double
        zmin = pEnv.zmin
        zmax = pEnv.zmax
      
        Dim zRange As Double
        zRange = zmax - zmin
      
        Dim baseHeight As Double
        baseHeight = zmax
              
        ' If height is constant it was already set above, outside of loop.
        ' Otherwise set it to attribute for feature.
        If (radAttribHeight) Then
          dHeight = pInFeature.Value(lInxHeightField)
          dHeight = dHeight * dZFact ' z unit conversion support
        End If
      
        ''''''
        ' Create a buffer inward from the footprint. This will represent the
        ' roof.
        ''''''
                                      
        ' Buffer has some problems with z aware geometry that has negative z
        ' values. Turn off awareness. Fixed at 8.2
        Dim pZAware As IZAware
        Set pZAware = pPoly
        pZAware.ZAware = False

        ' The interpolation process added vertices to the polygon in order to
        ' capture variance in height along the boundary. But because these
        ' densification points are all colinear in 2D they are just more work
        ' for buffer; remove them.
        Dim pPoly2 As IPolygon
        Dim pClone As IClone
        Set pClone = pPoly
        Set pPoly2 = pClone.Clone
        Dim pPolyCurve As IPolycurve
        Set pPolyCurve = pPoly2
        pPolyCurve.Generalize 0.001 ' TODO remove hardcode tolerance
        Dim pTopo As ITopologicalOperator2
        Set pTopo = pPolyCurve
        pTopo.Simplify ' must simplify after generalizing
                
        Dim pBuf As IPolygon
        Set pBuf = pTopo.Buffer(-dBufDist)
        
        ' Restore ZAwareness to our footprint polygon
        pZAware.ZAware = True
                
        ' Generalize the buffer result as building corners end up over sampled
        ' for this application.
        Set pPolyCurve = pBuf
        pPolyCurve.Generalize (dBufDist * 0.1)
                                                    
        ' Add footprint
        If (bAssignTags) Then
          Dim lTag As Long
          lTag = pInFeature.Value(lInxTagField)
          pTinEdit.AddShapeZ pPoly, esriTinHardValueFill, lTag
        Else
          pTinEdit.AddShapeZ pPoly, esriTinHardLine, lTag
        End If
                
        If (chkDeleteNodes.Value = 1) Then
          ' Remove all nodes completely contained by footprint. There is no need
          ' for them. This step could be skipped to make this process run through
          ' faster but overall it's better to remove unnecessary geometry otherwise
          ' you pay the price later.
          DeleteNodesInsidePoly pTinEdit, pPoly2 ' use poly2, this is generalized
        End If
        
        ' Get actual height to use for rooftop
        Dim dAppliedHeight As Double
        If (radHeightAbs) Then
          dAppliedHeight = dHeight
        Else
          dAppliedHeight = baseHeight + dHeight
        End If
                
        ' Add rooftop
        If (bAssignTags) Then
          pTinEdit.AddShape pBuf, esriTinHardReplace, lTag, dAppliedHeight
        Else
          pTinEdit.AddShape pBuf, esriTinHardReplace, 0, dAppliedHeight
        End If
      
      End If
      Set pInFeature = pInCursor.NextFeature
    Loop
                
    m_pApp.StatusBar.HideProgressBar
    
    If (radSaveOld) Then
      pTinEdit.StopEditing True
    Else
      pTinEdit.SaveAs txtOutName
      pTinEdit.StopEditing False
    End If
    
  Else
    Err.Raise -9999, "Add Buildings to TIN", "Unable to place TIN in edit mode."
  End If
  
  Me.MousePointer = vbDefault
  
  m_pMap.DeleteLayer m_pMap.Layer(cboInputTin.ItemData(cboInputTin.ListIndex))
  
  Set pTinLayer = New TinLayer
  Set pTinLayer.Dataset = pTinEdit
  Dim pLayer As ILayer
  Set pLayer = pTinLayer
  Set pDS = pTinEdit
  pLayer.name = pDS.name
  MiscUtil.AddLayer m_pApp, pTinLayer
    
  Unload Me
  
  Exit Sub
EH:
  MsgBox Err.Description, vbCritical, Err.Source
End Sub

' Designed to delete nodes that are completely inside, rather than inside AND
' coincident.
Private Sub DeleteNodesInsidePoly(pTinEdit As ITinEdit, pPoly As IPolygon)

  If (pTinEdit.IsInEditMode) Then
    Dim pTinSel As ITinSelection
    Set pTinSel = pTinEdit
    pTinSel.ClearSelection esriTinNode
    pTinSel.SelectByArea esriTinNode, pPoly, False, True, esriTinSelectionNew
    
    ' Now determine which of these are disjoint (non-coincident with boundary)
    Dim pEnum As IEnumTinNode
    Set pEnum = pTinSel.GetSelection(esriTinNode)
    
    Dim pNode As ITinNode
    Set pNode = New TinNode
    
    pEnum.QueryNext pNode
    
    Dim pPoint As IPoint
    Set pPoint = New Point
    
    Dim pRelOp As IRelationalOperator
    Set pRelOp = pPoly
    
    Dim pLongArray As ILongArray
    Set pLongArray = New LongArray
    
    Do While (Not pNode.IsEmpty)
      pNode.QueryAsPoint pPoint
      If (Not pRelOp.Touches(pPoint)) Then
        pLongArray.Add pNode.Index
      End If
      pEnum.QueryNext pNode
    Loop
    
    Dim pCount As Long
    pCount = pLongArray.Count
    
    If (pCount > 0) Then
      pTinSel.ClearSelection esriTinNode
      Dim i As Long
      For i = 0 To pCount - 1
        pTinSel.SetSelected pLongArray.Element(i), esriTinNode, esriTinSelectionAdd
      Next i
      pTinEdit.DeleteSelectedNodes
    End If
  End If
  
End Sub

Private Sub Form_Load()
  On Error GoTo EH
  
  ' Height conversion options
  cboZFactor.AddItem "none"
  cboZFactor.AddItem "feet to meters"
  cboZFactor.AddItem "meters to feet"
  cboZFactor.ListIndex = 0
  
  ' Get default output name for 'Save As' option.
  txtOutName = dbUtil.GetDefaultOutWorkspaceName
  txtOutName = txtOutName & "\" & dbUtil.GetUniqueFileName(txtOutName, "tin")
  
  ' Load up the input TIN and polygon combo boxes
  Dim lyrIndex As Long
  For lyrIndex = 0 To (m_pMap.LayerCount - 1)
    Dim pLayer As ILayer
    Set pLayer = m_pMap.Layer(lyrIndex)
    If (TypeOf pLayer Is ITinLayer) Then
      cboInputTin.AddItem pLayer.name
      cboInputTin.ItemData(cboInputTin.ListCount - 1) = lyrIndex
    ElseIf (TypeOf pLayer Is IFeatureLayer) Then
      Dim pFlayer As IFeatureLayer
      Set pFlayer = pLayer
      Dim pFC As IFeatureClass
      Set pFC = pFlayer.FeatureClass
      If (pFC.shapeType = esriGeometryPolygon) Then
        cboInputPoly.AddItem pLayer.name
        cboInputPoly.ItemData(cboInputPoly.ListCount - 1) = lyrIndex
      End If
    End If
  Next lyrIndex
  
  If (cboInputTin.ListCount > 0) Then
    cboInputTin.ListIndex = 0
  End If
  
  If (cboInputPoly.ListCount > 0) Then
    cboInputPoly.ListIndex = 0
  End If
  
  Exit Sub
EH:
  MsgBox Err.Description, vbCritical, Err.Source
End Sub

Private Sub SetInputTin()
  If (cboInputTin.ItemData(cboInputTin.ListIndex) >= 0) Then ' doc layer source
    Dim pLayer As ITinLayer
    Set pLayer = m_pMap.Layer(cboInputTin.ItemData(cboInputTin.ListIndex))
    Set m_pInputTin = pLayer.Dataset
  End If
End Sub

Private Sub SetInputPoly()
  If (cboInputPoly.ItemData(cboInputPoly.ListIndex) >= 0) Then ' doc layer source
    Dim pLayer As IFeatureLayer
    Set pLayer = m_pMap.Layer(cboInputPoly.ItemData(cboInputPoly.ListIndex))
    Set m_pInFClass = pLayer.FeatureClass
  End If
  
  LoadPolyFields
End Sub

Private Sub LoadPolyFields()

  cboElevFields.Clear
  cboBldgID.Clear
  
  Dim pFields As IFields
  Set pFields = m_pInFClass.Fields
  Dim pField As IField
  
  Dim lDefElevIndex As Long
  lDefElevIndex = -1
  
  Dim i As Long
  For i = 0 To (pFields.FieldCount - 1)
    Set pField = pFields.Field(i)
    If (pField.Type = esriFieldTypeDouble Or pField.Type = esriFieldTypeInteger Or _
        pField.Type = esriFieldTypeSingle Or pField.Type = esriFieldTypeSmallInteger) Then
      cboElevFields.AddItem pField.name
      cboElevFields.ItemData(cboElevFields.ListCount - 1) = i
      Dim sName As String
      sName = UCase(pField.name)
      If sName = "ELEVATION" Or sName = "ELEV" Or sName = "SPOT" Or _
         sName = "HEIGHT" Or sName = "HEIGHT_AG" Or sName = "Z" Then
        lDefElevIndex = cboElevFields.ListCount - 1
      End If
      cboBldgID.AddItem pField.name
      cboBldgID.ItemData(cboBldgID.ListCount - 1) = i
      cboTagFields.AddItem pField.name
      cboTagFields.ItemData(cboBldgID.ListCount - 1) = i
    End If
  Next i
  
  If (cboElevFields.ListCount > 0) Then
    If (lDefElevIndex > -1) Then
      cboElevFields.ListIndex = lDefElevIndex
      radAttribHeight.Value = True
    Else
      cboElevFields.ListIndex = 0
    End If
  End If
    
  If (cboBldgID.ListCount > 0) Then
    cboBldgID.ListIndex = 0
  End If

  If (cboTagFields.ListCount > 0) Then
    cboTagFields.ListIndex = 0
  End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set m_pApp = Nothing
  Set m_pMap = Nothing
  Set m_pInputTin = Nothing
  Set m_pInFClass = Nothing
End Sub

Private Function ValidateInputs() As Boolean
  On Error GoTo EH
  
  ValidateInputs = False
  
  Dim sOutDir As String
  Dim sOutName As String
  If (Not dbUtil.ResolveOutputTinName(txtOutName, sOutDir, sOutName)) Then
    If (dbUtil.GetErrorCode = 1) Then
      MsgBox dbUtil.GetErrorMessage, vbCritical
    End If
    Exit Function
  End If
  
  If (cboZFactor.ListIndex = -1) Then
    If (Not IsNumeric(cboZFactor)) Then
      MsgBox "The conversion factor provided is not a valid number.", vbInformation
      Exit Function
    ElseIf (CDbl(cboZFactor) = 0#) Then
      MsgBox "The conversion factor provided can not be equal to 0.0"
      Exit Function
    End If
  End If
    
  Dim d As Double
  If (radConstHeight) Then
    If (Not IsNumeric(txtHeight)) Then
      MsgBox "Building height specified is not a valid number.", vbInformation
      Exit Function
    Else
      d = CStr(txtHeight)
      If (d <= 0) Then
        MsgBox "Building height needs to be greater than 0.0.", vbInformation
        Exit Function
      End If
    End If
  End If
  
  If (Not IsNumeric(txtBuffer)) Then
    MsgBox "The rooftop buffer specified is not a valid number.", vbInformation
    Exit Function
  Else
    d = CStr(txtBuffer)
    If (d <= 0) Then
      MsgBox "Rooftop buffer needs to be greater than 0.0.", vbInformation
      Exit Function
    End If
  End If
    
  ValidateInputs = True
  
  Exit Function
EH:
  MsgBox Err.Description, vbCritical, Err.Source
End Function

Private Sub txtHeight_GotFocus()
  radConstHeight.Value = True
End Sub

Private Sub txtOutName_GotFocus()
  radSaveNew = True
End Sub

Public Sub StatusBarMessage(sMsg)
  m_pApp.StatusBar.Message(0) = sMsg
  DoEvents
End Sub