frmfishnet.frm

地表的fishn额头

VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Begin VB.Form frmFishnet 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Create Fishnet From Surface"
   ClientHeight    =   4344
   ClientLeft      =   48
   ClientTop       =   336
   ClientWidth     =   4788
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4344
   ScaleWidth      =   4788
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.Frame Frame2 
      Caption         =   "Settings"
      Height          =   1335
      Left            =   120
      TabIndex        =   14
      Top             =   1080
      Width           =   4575
      Begin VB.CheckBox chkDomain 
         Caption         =   "Include interpolation zone boundary"
         Height          =   255
         Left            =   120
         TabIndex        =   17
         Top             =   480
         Value           =   1  'Checked
         Width           =   2775
      End
      Begin VB.TextBox txtNumLines 
         Height          =   315
         Left            =   3960
         TabIndex        =   16
         Text            =   "txtNumLines"
         Top             =   200
         Width           =   495
      End
      Begin VB.CheckBox chkAutoGroup 
         Caption         =   "Group the surface and fishnet layers and set visibility properties to optimize navigation performance."
         Height          =   495
         Left            =   120
         TabIndex        =   15
         Top             =   720
         Value           =   1  'Checked
         Width           =   4335
      End
      Begin VB.Label Label3 
         Caption         =   "Approximate number of mesh lines on longest side:"
         Height          =   252
         Left            =   120
         TabIndex        =   18
         Top             =   240
         Width           =   3732
      End
   End
   Begin VB.CommandButton cmdBrowseInput 
      Height          =   315
      Left            =   4320
      Style           =   1  'Graphical
      TabIndex        =   1
      Top             =   720
      UseMaskColor    =   -1  'True
      Width           =   375
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "OK"
      Height          =   315
      Left            =   2880
      TabIndex        =   2
      Top             =   3960
      Width           =   855
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "Cancel"
      Height          =   315
      Left            =   3840
      TabIndex        =   3
      Top             =   3960
      Width           =   855
   End
   Begin VB.ComboBox cboInput 
      Height          =   288
      Left            =   1200
      Style           =   2  'Dropdown List
      TabIndex        =   0
      Top             =   720
      Width           =   3015
   End
   Begin VB.Frame Frame1 
      Caption         =   "Output specification"
      Height          =   1335
      Left            =   120
      TabIndex        =   7
      Top             =   2520
      Width           =   4575
      Begin VB.CommandButton cmdBrowseOutput 
         Height          =   315
         Left            =   4080
         Style           =   1  'Graphical
         TabIndex        =   11
         Top             =   840
         UseMaskColor    =   -1  'True
         Width           =   375
      End
      Begin VB.TextBox txtOutput 
         Height          =   315
         Left            =   120
         TabIndex        =   10
         Text            =   "txtOutput"
         Top             =   840
         Width           =   3855
      End
      Begin VB.OptionButton radOutputFeatures 
         Caption         =   "Feature class"
         Height          =   255
         Left            =   1680
         TabIndex        =   9
         Top             =   480
         Width           =   1335
      End
      Begin VB.OptionButton radOutputGraphics 
         Caption         =   "Graphics layer"
         Height          =   255
         Left            =   1680
         TabIndex        =   8
         Top             =   240
         Value           =   -1  'True
         Width           =   1935
      End
      Begin VB.Label Label6 
         Caption         =   "Write results to:"
         Height          =   255
         Left            =   120
         TabIndex        =   13
         Top             =   240
         Width           =   1335
      End
      Begin VB.Label Label5 
         Caption         =   "Name:"
         Height          =   255
         Left            =   120
         TabIndex        =   12
         Top             =   600
         Width           =   615
      End
   End
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   120
      Top             =   3720
      _ExtentX        =   995
      _ExtentY        =   995
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   15
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   1
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmFishnet.frx":0000
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Label Label2 
      Caption         =   "Output name:"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   3120
      Width           =   1095
   End
   Begin VB.Label Label4 
      Caption         =   "Creates a mesh of 3D lines by generating a series of profiles spaced at a regular interval."
      Height          =   492
      Left            =   120
      TabIndex        =   5
      Top             =   120
      Width           =   4572
   End
   Begin VB.Label Label1 
      Caption         =   "Input surface:"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   740
      Width           =   975
   End
End
Attribute VB_Name = "frmFishnet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

' 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

Private m_pApp As IApplication
Private m_pMap As IBasicMap
Private m_pLayer As ILayer
Private m_pInputGDS As IGeoDataset
Private m_sDefaultFClassName As String

Public Sub Init(pApp As IApplication)
  Set m_pApp = pApp
  If (TypeOf m_pApp Is IMxApplication) Then
    Dim pMxDoc As IMxDocument
    Set pMxDoc = m_pApp.Document
    Set m_pMap = pMxDoc.FocusMap
  ElseIf (TypeOf m_pApp Is ISxApplication) Then
    Dim pSxDoc As ISxDocument
    Set pSxDoc = m_pApp.Document
    Set m_pMap = pSxDoc.Scene
  End If
End Sub

Private Sub cboInput_Click()
  SetInputGeodataset
  SetOutputName
  UpdateOKEnabled
End Sub

Private Sub cmdBrowseInput_Click()
  Dim pGxObject As IGxObject
  Dim pFilter As GxFilterSurfaceDatasets
  Dim pMiniBrowser As IGxDialog
  Dim pEnumGxObject As IEnumGxObject
  
  Set pMiniBrowser = New GxDialog
  Set pFilter = New GxFilterSurfaceDatasets
  
  Set pMiniBrowser.ObjectFilter = pFilter
  pMiniBrowser.Title = "Select Surface"
  
  If (pMiniBrowser.DoModalOpen(Me.hwnd, pEnumGxObject)) Then
    Set pGxObject = pEnumGxObject.Next
    Dim pGxDataset As IGxDataset
    Set pGxDataset = pGxObject
    Dim pDataset As esriGeoDatabase.IDataset
    Set pDataset = pGxDataset.Dataset
    If (TypeOf pDataset Is IRasterBandCollection) Then
      Dim pRasterBands As IRasterBandCollection
      Set pRasterBands = pDataset
      Set m_pInputGDS = pRasterBands.Item(0)
    Else
      Set m_pInputGDS = pDataset
    End If
    cboInput.Clear
    cboInput.AddItem pDataset.name
    cboInput.ItemData(cboInput.ListCount - 1) = -1 ' -1 indicates browsed data, not map layer
    cboInput.ListIndex = 0
  End If
  
  ' move the focus off this command so OK or Cancel can be default if 'Enter' hit
  If (cmdOK.Enabled) Then
    cmdOK.SetFocus
  Else
    cmdCancel.SetFocus
  End If
  
End Sub

Private Sub cmdBrowseOutput_Click()
  Dim sName As String
  sName = txtOutput.Text
  Dim sLocation As String
  sLocation = cmdBrowseOutput.ToolTipText
  If (dbUtil.BrowseForOutputName(sName, sLocation, esriDTFeatureClass, Me.hwnd)) Then
    txtOutput.Text = sName
    cmdBrowseOutput.ToolTipText = sLocation
  End If
  txtOutput.SelStart = Len(txtOutput.Text) ' position cursor at end of string
End Sub

Private Sub cmdOK_Click()

  On Error GoTo err
  
  Dim sOutWKSName As String
  Dim sOutDSName As String
  Dim sOutFCName As String
  Dim sOutCat As String
  Dim pOutFClass As IFeatureClass
  
  If (radOutputFeatures.Value = True) Then
    If (Not dbUtil.ResolveOutputFeatureClassName(txtOutput.Text, sOutCat, sOutWKSName, sOutDSName, sOutFCName, True)) Then
      If (dbUtil.GetErrorCode = 1) Then
        MsgBox dbUtil.GetErrorMessage, vbExclamation
      End If
      Exit Sub
    End If
        
    Set pOutFClass = dbUtil.CreateOutFClass(sOutCat, sOutWKSName, sOutDSName, _
      sOutFCName, esriGeometryPolyline, False, True, m_pInputGDS.SpatialReference)
      
    If (pOutFClass Is Nothing) Then
      ' This is just for safety. Probably should not end up here. If there was
      ' a problem making the output feature class an error should have been
      ' raised.
      MsgBox "Error creating feature class", vbCritical, "Fishnet"
      Me.MousePointer = vbDefault
      Exit Sub
    End If
    
    Dim pCursor As IFeatureCursor
    Set pCursor = pOutFClass.Insert(True)

    Dim pBuffer As IFeatureBuffer
    Set pBuffer = pOutFClass.CreateFeatureBuffer
  Else
    Dim pElement As IElement
    Set pElement = New LineElement
    Dim pLineElement As ILineElement
    Set pLineElement = pElement
    pLineElement.Symbol = MiscUtil.GetDefaultSymbol(m_pApp, esriGeometryPolyline)
    
    Dim pLineForGraphics As IGeometryCollection
    Set pLineForGraphics = New Polyline
    
    ' Graphics geometry needs to be zaware
    Dim pZAware As IZAware
    Set pZAware = pLineForGraphics
    pZAware.ZAware = True
    
    ' Graphics geometry needs its spatial reference defined
    Dim pGeom As IGeometry
    Set pGeom = pLineForGraphics
    Set pGeom.SpatialReference = m_pInputGDS.SpatialReference