frmfishnet.frm

地表的fishn额头

  End If
              
  Me.MousePointer = vbHourglass
                
  Dim pEnv As IEnvelope
  Set pEnv = m_pInputGDS.Extent
    
  ' Get ISurface
  Dim pSurf As ISurface
  If (TypeOf m_pInputGDS Is iRasterBand) Then
    Dim pRastSurf As IRasterSurface
    Set pRastSurf = New RasterSurface
    pRastSurf.RasterBand = m_pInputGDS
    Set pSurf = pRastSurf
    
    ' Correct the envelope when input is raster as its interpolation
    ' zone is shrunk in 1/2 cell (it only goes out as far as cell center
    ' points because estimating heights beyond that would be extrapolation).
    Dim pProps As IRasterProps
    Set pProps = m_pInputGDS
    Dim dCellsize As Double
    dCellsize = (pProps.MeanCellSize.x + pProps.MeanCellSize.y) * 0.5
    Debug.Print pEnv.xmin & " " & pEnv.xmax
    pEnv.Expand dCellsize * -0.5, dCellsize * -0.5, False
    Debug.Print pEnv.xmin & " " & pEnv.xmax
  Else
    Set pSurf = m_pInputGDS
  End If
        
  ' Determine the mesh step interval
  Dim lNumLines As Long
  lNumLines = CLng(txtNumLines)
  
  Dim dStep As Double
  If (pEnv.Width > pEnv.Height) Then
    dStep = CStr(pEnv.Width / (lNumLines - 1))
  Else
    dStep = CStr(pEnv.Height / (lNumLines - 1))
  End If
    
  ' If the interpolation zone boundary is included then the fishnet should
  ' not attempt to start and end on boundary edges.
  Dim dOffset As Double
  If (chkDomain.Value = 1) Then
    dOffset = dStep
  Else
    dOffset = 0
  End If
  
  ' Create objects where possible outside of profile loops for performance
  Dim pPoint As IPoint
  Set pPoint = New Point
  
  Dim pInProfile As IPointCollection
  Set pInProfile = New Polyline
  
  Dim pInProfileGeom As IGeometry
  Set pInProfileGeom = pInProfile
  
  ' Loop through profiles. Because of floating point math precision issues
  ' add a little fuzziness (i.e. "+ (dStep * 0.5)") so the mesh doesn't stop
  ' short at max positions.
  Dim x As Double
  For x = (pEnv.xmin + dOffset) To (pEnv.xmax - dOffset + (dStep * 0.5)) Step dStep
    pInProfileGeom.SetEmpty
    pPoint.x = x
    pPoint.y = pEnv.ymin
    pInProfile.AddPoint pPoint
    pPoint.y = pEnv.ymax
    pInProfile.AddPoint pPoint
    Dim pOutProfile As IPolyline
    pSurf.GetProfile pInProfile, pOutProfile
    If (Not pOutProfile Is Nothing) Then
      If (radOutputFeatures.Value = True) Then
        Set pBuffer.Shape = pOutProfile
        pCursor.InsertFeature pBuffer
      Else
        pLineForGraphics.AddGeometryCollection pOutProfile
      End If
    End If
  Next x
            
  Dim y As Double
  For y = (pEnv.ymin + dOffset) To (pEnv.ymax - dOffset + (dStep * 0.5)) Step dStep
    pInProfileGeom.SetEmpty
    pPoint.x = pEnv.xmin
    pPoint.y = y
    pInProfile.AddPoint pPoint
    pPoint.x = pEnv.xmax
    pInProfile.AddPoint pPoint
    pSurf.GetProfile pInProfile, pOutProfile
    If (Not pOutProfile Is Nothing) Then
      If (radOutputFeatures.Value = True) Then
        Set pBuffer.Shape = pOutProfile
        pCursor.InsertFeature pBuffer
      Else
        pLineForGraphics.AddGeometryCollection pOutProfile
      End If
    End If
  Next y
      
  ' See if interpolation zone is to be included.
  If (chkDomain.Value = 1) Then
    Dim pDomain As IGeometryCollection
    Set pDomain = pSurf.Domain
        
    pInProfileGeom.SetEmpty
    
    Dim pInProfileCol As IGeometryCollection
    Set pInProfileCol = pInProfile
    
    ' Convert to polygon to a polyline by bringing over
    ' rings as paths.
    Dim i As Long
    For i = 0 To (pDomain.GeometryCount - 1)
      Dim pPath As IPointCollection
      Set pPath = New Path
      pPath.AddPointCollection pDomain.Geometry(i)
      pInProfileCol.AddGeometry pPath
    Next i
        
    pSurf.GetProfile pInProfile, pOutProfile
            
    If (Not pOutProfile Is Nothing) Then
      If (radOutputFeatures.Value = True) Then
        Set pBuffer.Shape = pOutProfile
        pCursor.InsertFeature pBuffer
      Else
        pLineForGraphics.AddGeometryCollection pOutProfile
      End If
    End If
  End If
    
  Dim pLayer As ILayer
        
  If (radOutputFeatures.Value = True) Then
    ' Clear and flush feature class
    Set pBuffer = Nothing
    Set pCursor = Nothing
  
    Dim pFLayer As IFeatureLayer
    Set pFLayer = New FeatureLayer
    Set pFLayer.FeatureClass = pOutFClass
    Set pLayer = pFLayer
    Dim pFO As FileSystemObject
    Set pFO = New FileSystemObject
    pLayer.name = pFO.GetBaseName(txtOutput.Text)
    Dim pOut3DProps As I3DProperties
    Set pOut3DProps = New Feature3DProperties
  Else
    Dim pGLayer As IGraphicsContainer3D
    Set pGLayer = New GraphicsLayer3D
    pElement.Geometry = pLineForGraphics
    pGLayer.AddElement pElement
    Set pLayer = pGLayer
    pLayer.name = txtOutput.Text
    Set pOut3DProps = New Basic3DProperties
  End If
    
  ' Copy over the z unit conversion factor (as set on base heights tab)
  Dim pIn3DProps As I3DProperties
  If (Not m_pLayer Is Nothing) Then
    Set pIn3DProps = Get3DLayerProps(m_pLayer)
    pOut3DProps.ZFactor = pIn3DProps.ZFactor
    ' Because graphics layers ignore the z factor property, apply it to the
    ' geometry directly. This is considered a bug. The following code is a
    ' workaround and should be removed when fixed (bug id# cq00151916)
    If (radOutputGraphics.Value = True) And (pOut3DProps.ZFactor <> 1#) Then
      Dim pZ As IZCollection
      Set pZ = pElement.Geometry
      pZ.MultiplyZs pOut3DProps.ZFactor
      pElement.Geometry = pZ
    End If
  End If
  
  Dim pLE As ILayerExtensions
  Set pLE = pLayer
  pLE.AddExtension pOut3DProps
  
  ' Support for grouping option. Option should only be enabled if in
  ' ArcScene and input surface comes from a layer rather than a browsed
  ' dataset.
  If (chkAutoGroup.Value = 1) Then
  
    ' Remove original surface layer from TOC and move to group
    m_pMap.DeleteLayer m_pLayer
    Dim pGroupLayer As IGroupLayer
    Set pGroupLayer = New GroupLayer
    pGroupLayer.Add m_pLayer
                
    ' Set visibility for original surface. Since it's in a scene we
    ' know it has 3DProps extension.
    pIn3DProps.RenderVisibility = esriRenderWhenStopped
                    
    ' Set visibility for mesh.
    pOut3DProps.RenderVisibility = esriRenderWhenNavigating
                
    ' Add mesh to group layer
    pGroupLayer.Add pLayer
    
    ' Name group layer and add to scene
    Set pLayer = pGroupLayer
    pLayer.name = m_pLayer.name & " group"
    
    pGroupLayer.Expanded = False
    m_pMap.AddLayer pGroupLayer
  Else
    m_pMap.AddLayer pLayer
  End If
  
  Me.MousePointer = vbDefault
  Unload Me
  Exit Sub
  
err:
  Me.MousePointer = vbDefault
  MsgBox err.Description, vbCritical, "Fishnet"
End Sub

Private Sub cmdCancel_Click()
  Unload Me
End Sub

Private Sub Form_Load()
  Me.Icon = Nothing
    
  cmdBrowseInput.Picture = ImageList1.ListImages.Item(1).Picture
  cmdBrowseOutput.Picture = ImageList1.ListImages.Item(1).Picture
  cmdBrowseOutput.ToolTipText = dbUtil.GetDefaultOutWorkspaceName
    
  m_sDefaultFClassName = ""
  
  If (TypeOf m_pApp Is IMxApplication) Then
    ' 3D graphics layer option should be disabled
    radOutputGraphics.Enabled = False
  End If
  
  If (radOutputGraphics.Enabled) Then
    cmdBrowseOutput.Enabled = False
    radOutputGraphics.Value = True
    txtOutput.Text = "mesh graphics"
  Else
    cmdBrowseOutput.Enabled = True
    radOutputFeatures.Value = True
  End If
  
  txtNumLines = "50"
  
  cboInput.Clear
  Dim index, lyrIndex As Long
  Dim pLyr As ILayer
  For lyrIndex = 0 To m_pMap.LayerCount - 1
    Set pLyr = m_pMap.Layer(lyrIndex)
    If (TypeOf pLyr Is ITinLayer Or _
        TypeOf pLyr Is IRasterLayer) Then
      cboInput.AddItem pLyr.name
      cboInput.ItemData(cboInput.ListCount - 1) = lyrIndex
    End If
  Next lyrIndex
  
  If (cboInput.ListCount > 0) Then
    cboInput.ListIndex = 0
  Else
    UpdateOKEnabled
  End If
  
End Sub

Private Sub SetInputGeodataset()
  If (cboInput.ItemData(cboInput.ListIndex) >= 0) Then ' doc layer source
    Set m_pLayer = m_pMap.Layer(cboInput.ItemData(cboInput.ListIndex))
    If (TypeOf m_pLayer Is ITinLayer) Then
      Dim pTinLayer As ITinLayer
      Set pTinLayer = m_pLayer
      Set m_pInputGDS = pTinLayer.Dataset
    Else
      Dim pRasterLayer As IRasterLayer
      Set pRasterLayer = m_pLayer
      Dim pRasterBands As IRasterBandCollection
      Set pRasterBands = pRasterLayer.raster
      Set m_pInputGDS = pRasterBands.Item(0)
    End If
  Else                     ' if ItemData is '-1' then browsed data source
    Set m_pLayer = Nothing ' if user browsed there's only one dataset around
  End If                   'and it's already set
End Sub

Private Sub UpdateOKEnabled()
  If ((cboInput.ListCount > 0) And (txtOutput.Text <> "")) Then
    cmdOK.Enabled = True
    cmdOK.Default = True
  Else
    cmdOK.Enabled = False
    cmdCancel.Default = True
  End If
  UpdateAutoGroupEnabled
End Sub

Private Sub UpdateAutoGroupEnabled()
  ' Enable only if in ArcScene and the selected surface is from a layer
  ' as opposed to being a browsed dataset.
  If ((TypeOf m_pApp Is ISxApplication) And (Not m_pLayer Is Nothing)) Then
    chkAutoGroup.Enabled = True
    chkAutoGroup.Value = 1
  Else
    chkAutoGroup.Value = 0
    chkAutoGroup.Enabled = False
  End If
End Sub

Private Function Get3DLayerProps(pLayer As ILayer) As I3DProperties
  Set Get3DLayerProps = Nothing
  Dim pLayerExts As ILayerExtensions
  Set pLayerExts = pLayer
  Dim lExtensionIndex As Long
  For lExtensionIndex = 0 To (pLayerExts.ExtensionCount - 1)
    If (TypeOf pLayerExts.Extension(lExtensionIndex) Is I3DProperties) Then
      Set Get3DLayerProps = pLayerExts.Extension(lExtensionIndex)
      Exit For
    End If
  Next lExtensionIndex
End Function

Private Sub SetOutputName()
  If (radOutputFeatures.Value = True) Then
    If (m_sDefaultFClassName <> "") Then
      txtOutput.Text = m_sDefaultFClassName
    Else
      Dim pWS As IFeatureWorkspace
      Set pWS = dbUtil.OpenFeatureWorkspace(cmdBrowseOutput.ToolTipText)
      m_sDefaultFClassName = cmdBrowseOutput.ToolTipText & "\" & dbUtil.GetUniqueFeatureClassName(pWS, "mesh")
      txtOutput.Text = m_sDefaultFClassName
      txtOutput.SelStart = Len(txtOutput.Text)  ' position cursor at end of string
    End If
  Else
    txtOutput.Text = cboInput.Text & " mesh graphics"
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set m_pApp = Nothing
  Set m_pMap = Nothing
  Set m_pLayer = Nothing
  Set m_pInputGDS = Nothing
End Sub

Private Sub radOutputFeatures_Click()
  cmdBrowseOutput.Enabled = True
  SetOutputName
End Sub

Private Sub radOutputGraphics_Click()
  cmdBrowseOutput.Enabled = False
  SetOutputName
End Sub