createnewtin.frm

arcgis 编程学习事例

VERSION 5.00
Begin VB.Form frmCreateNewTin 
   BorderStyle     =   4  'Fixed ToolWindow
   Caption         =   "Create New TIN"
   ClientHeight    =   1812
   ClientLeft      =   48
   ClientTop       =   348
   ClientWidth     =   4188
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1812
   ScaleWidth      =   4188
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdBrowseOutput 
      Height          =   315
      Left            =   3720
      Picture         =   "CreateNewTin.frx":0000
      Style           =   1  'Graphical
      TabIndex        =   8
      Top             =   1080
      Width           =   315
   End
   Begin VB.TextBox txtOutput 
      Height          =   285
      Left            =   120
      TabIndex        =   7
      Text            =   "txtOutName"
      Top             =   1080
      Width           =   3495
   End
   Begin VB.ComboBox cboProjectionSource 
      Height          =   315
      Left            =   1680
      Style           =   2  'Dropdown List
      TabIndex        =   5
      Top             =   480
      Width           =   2415
   End
   Begin VB.ComboBox cboExtentSource 
      Height          =   315
      Left            =   1680
      Style           =   2  'Dropdown List
      TabIndex        =   3
      Top             =   120
      Width           =   2415
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "Cancel"
      Height          =   315
      Left            =   3120
      TabIndex        =   1
      Top             =   1440
      Width           =   975
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "OK"
      Height          =   315
      Left            =   2040
      TabIndex        =   0
      Top             =   1440
      Width           =   975
   End
   Begin VB.Label Label3 
      Caption         =   "Output name:"
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   840
      Width           =   1095
   End
   Begin VB.Label Label2 
      Caption         =   "Use projection from:"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   480
      Width           =   1455
   End
   Begin VB.Label Label1 
      Caption         =   "Use extent from:"
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   120
      Width           =   1215
   End
End
Attribute VB_Name = "frmCreateNewTin"
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]

Private m_pApp As IApplication
Private m_pMap As IBasicMap

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 cmdCancel_Click()
  Unload Me
End Sub

Private Sub cmdOK_Click()
  Dim sOutDir As String
  Dim sOutName As String
  If (Not dbUtil.ResolveOutputTinName(txtOutput, sOutDir, sOutName)) Then
    If (dbUtil.GetErrorCode = 1) Then
      MsgBox dbUtil.GetErrorMessage, vbExclamation
    End If
    Exit Sub
  End If
  
  Dim pMxDoc As IMxDocument
  Set pMxDoc = m_pApp.Document
  
  If (cboExtentSource.ListIndex = 0) Then     ' current display extent
    Dim pEnv As IEnvelope
    Set pEnv = pMxDoc.ActiveView.Extent
  ElseIf (cboExtentSource.ListIndex = 1) Then ' extent of all layers
    Set pEnv = pMxDoc.ActiveView.FullExtent
  Else                                        ' extent of specific layer
    Dim pLayer As ILayer
    Set pLayer = m_pMap.Layer(cboExtentSource.ItemData(cboExtentSource.ListIndex))
    Set pEnv = pLayer.AreaOfInterest
  End If
  
  If (cboProjectionSource.ListIndex = 0) Then ' use the map's projection
    Dim pSR As ISpatialReference
    Set pSR = m_pMap.SpatialReference
  Else                                        ' use a specific layer's
    Set pLayer = m_pMap.Layer(cboProjectionSource.ItemData(cboProjectionSource.ListIndex))
    Set pSR = dbUtil.GetLayerSourceSpatialRef(pLayer)
  End If
  
  Dim pGeom As IGeometry
  Set pGeom = pEnv
  pGeom.Project pSR
 
  Dim pTinEdit As ITinEdit
  Set pTinEdit = New Tin
  pTinEdit.InitNew pEnv

  pTinEdit.SaveAs sOutDir & "\" & sOutName, False
  
  Dim pTinLayer As ITinLayer
  Set pTinLayer = New TinLayer
  Set pTinLayer.Dataset = pTinEdit
  
  pTinLayer.ClearRenderers
  
  Set pLayer = pTinLayer
  pLayer.name = sOutName
  miscUtil.AddLayer m_pApp, pTinLayer
  
  Unload Me
End Sub

Private Sub Form_Load()
  On Error GoTo EH
  
  Me.Icon = Nothing
  
  cmdBrowseOutput.ToolTipText = dbUtil.GetDefaultOutWorkspaceName("TIN")
  
  txtOutput = cmdBrowseOutput.ToolTipText & "\" & dbUtil.GetUniqueFileName(cmdBrowseOutput.ToolTipText, "tin")
  txtOutput.SelStart = Len(txtOutput.Text) ' position cursor at end of string
  
  cboExtentSource.Clear
  cboExtentSource.AddItem "Current display extent"
  cboExtentSource.AddItem "Full extent of all layers"
  
  Dim index As Long
  Dim lyrIndex As Long
  Dim pLyr As ILayer
  For lyrIndex = 0 To m_pMap.LayerCount - 1
    Set pLyr = m_pMap.Layer(lyrIndex)
    cboExtentSource.AddItem pLyr.name
    cboExtentSource.ItemData(cboExtentSource.ListCount - 1) = lyrIndex
  Next lyrIndex
  cboExtentSource.ListIndex = 0
  
  cboProjectionSource.Clear
  cboProjectionSource.AddItem "Current display"
  
  For lyrIndex = 0 To m_pMap.LayerCount - 1
    Set pLyr = m_pMap.Layer(lyrIndex)
    cboProjectionSource.AddItem pLyr.name
    cboProjectionSource.ItemData(cboProjectionSource.ListCount - 1) = lyrIndex
  Next lyrIndex
  cboProjectionSource.ListIndex = 0
 
  Exit Sub
EH:
  MsgBox Err.Description, vbCritical, Err.Source
End Sub

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