frmsurfaceilbyvalue.frm

超图网络分析扩展的VB开发程序的应用,对地理信息系统开发有益

VERSION 5.00
Begin VB.Form frmSurfaceILByValue 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "指定坐标值生成等高线"
   ClientHeight    =   3180
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4905
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3180
   ScaleWidth      =   4905
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.Frame Frame2 
      Caption         =   "坐标设置"
      Height          =   1350
      Left            =   1515
      TabIndex        =   7
      Top             =   1170
      Width           =   3390
      Begin VB.TextBox txtSmooth 
         Height          =   285
         Left            =   2550
         TabIndex        =   15
         Text            =   "2"
         Top             =   915
         Width           =   795
      End
      Begin VB.TextBox txtZValue 
         Height          =   285
         Left            =   1005
         TabIndex        =   14
         Text            =   "0"
         Top             =   915
         Width           =   825
      End
      Begin VB.Label lblMin 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1005
         TabIndex        =   13
         Top             =   630
         Width           =   2340
      End
      Begin VB.Label lblMax 
         BorderStyle     =   1  'Fixed Single
         Height          =   255
         Left            =   1005
         TabIndex        =   12
         Top             =   330
         Width           =   2340
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "光滑度："
         Height          =   195
         Index           =   5
         Left            =   1875
         TabIndex        =   11
         Top             =   945
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "高程值："
         Height          =   195
         Index           =   4
         Left            =   345
         TabIndex        =   10
         Top             =   945
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "最小高程："
         Height          =   195
         Index           =   3
         Left            =   165
         TabIndex        =   9
         Top             =   630
         Width           =   900
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "最大高程："
         Height          =   195
         Index           =   2
         Left            =   165
         TabIndex        =   8
         Top             =   330
         Width           =   900
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "参加分析的数据"
      Height          =   1170
      Left            =   1515
      TabIndex        =   2
      Top             =   15
      Width           =   3390
      Begin VB.ComboBox cmbDtList 
         Height          =   315
         Left            =   1095
         Style           =   2  'Dropdown List
         TabIndex        =   4
         Top             =   705
         Width           =   2100
      End
      Begin VB.ComboBox cmbDsList 
         Height          =   315
         Left            =   1095
         Style           =   2  'Dropdown List
         TabIndex        =   3
         Top             =   255
         Width           =   2100
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "数据集："
         Height          =   195
         Index           =   1
         Left            =   340
         TabIndex        =   6
         Top             =   705
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "数据源："
         Height          =   195
         Index           =   0
         Left            =   340
         TabIndex        =   5
         Top             =   330
         Width           =   720
      End
   End
   Begin VB.CommandButton cmdOk 
      Caption         =   "确定"
      Height          =   435
      Left            =   2775
      TabIndex        =   1
      Top             =   2655
      Width           =   945
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消"
      Height          =   435
      Left            =   3885
      TabIndex        =   0
      Top             =   2655
      Width           =   945
   End
   Begin VB.Image Image1 
      Appearance      =   0  'Flat
      BorderStyle     =   1  'Fixed Single
      Height          =   3180
      Left            =   30
      Picture         =   "frmSurfaceILByValue.frx":0000
      Stretch         =   -1  'True
      Top             =   0
      Width           =   1455
   End
End
Attribute VB_Name = "frmSurfaceILByValue"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim dx As Double
Dim dy As Double

Private Sub cmbDsList_Click()
    If cmbDsList.Text = "" Then Exit Sub
    If frmMain.bActiveFrm Then
        ChangeDs cmbDsList.Text, cmbDtList
    End If
End Sub

Private Sub cmbDtList_Click()
    If cmbDtList.Text = "" Then Exit Sub
    If frmMain.bActiveFrm Then
        InitXYValue
    End If
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdOk_Click()
    Dim objDs As soDataSource
    Dim objDtRst As soDatasetRaster
    Dim objGeoLine As soGeoLine
    Dim objStyle As New soStyle
    Dim objSurfaceAnalyst As soSurfaceAnalyst
    Dim objSurfaceOperator As soSurfaceOperator
    Dim objError As New soError
    
    Set objDs = frmMain.SuperWorkspace.Datasources(cmbDsList.Text)
    Set objDtRst = objDs.Datasets(cmbDtList.Text)
    Set objSurfaceAnalyst = frmMain.SuperAnalyst.SurfaceAnalyst
    Set objSurfaceOperator = objSurfaceAnalyst.Surface
    Set objSurfaceAnalyst.AnalysisEnvionment = frmMain.objAnalystEnvmnt
    Set objGeoLine = objSurfaceOperator.IsolineByValue(objDtRst, CDbl(txtZValue.Text), CInt(txtSmooth.Text))
    If Not objGeoLine Is Nothing Then
        objStyle.PenColor = vbRed
        objStyle.PenWidth = 15
        frmMain.SuperMap.Layers.RemoveAll
        frmMain.SuperMap.Layers.AddDataset objDtRst, True
        frmMain.SuperMap.TrackingLayer.ClearEvents
        frmMain.SuperMap.TrackingLayer.AddEvent objGeoLine, objStyle, ""
        frmMain.SuperMap.ViewEntire
        frmMain.SuperMap.Refresh
    Else
        MsgBox "生成等值线失败" & vbCrLf & objError.LastErrorMsg, vbInformation, "信息提示"
    End If
    
    Set objError = Nothing
    Set objStyle = Nothing
    Set objGeoLine = Nothing
    Set objDtRst = Nothing
    Set objDs = Nothing
    Set objSurfaceAnalyst = Nothing
    Set objSurfaceOperator = Nothing
    
    Unload Me
End Sub

Private Sub Form_Activate()
    frmMain.bActiveFrm = True
    cmbDsList_Click
End Sub

Private Sub InitXYValue()
    Dim objDtRst As soDatasetRaster
    Dim objDs As soDataSource
    Dim strDs As String
    Dim strDt As String
    
    strDs = cmbDsList.Text
    strDt = cmbDtList.Text
    Set objDs = frmMain.SuperWorkspace.Datasources(strDs)
    Set objDtRst = objDs.Datasets(strDt)
    dx = objDtRst.MaxZ
    dy = objDtRst.MinZ
    lblMax.Caption = dx
    lblMax.ToolTipText = lblMax.Caption
    lblMax.Refresh
    lblMin.Caption = dy
    lblMin.ToolTipText = lblMin.Caption
    lblMin.Refresh
    dx = (dx - dy) / 2
    txtZValue.Text = CInt(dx)
    
    Set objDs = Nothing
    Set objDtRst = Nothing
End Sub


Private Sub txtZValue_Change()
    If (Trim(txtZValue.Text) = "") Then txtZValue.Text = CInt(dx)
End Sub

Private Sub txtZValue_KeyPress(KeyAscii As Integer)
    If (KeyAscii > Asc("9")) Or (KeyAscii < Asc("0")) Then
        If (KeyAscii <> vbKeyBack) And (KeyAscii <> Asc(".")) Then
            KeyAscii = 0
            Beep
        End If
    End If
End Sub

Private Sub txtSmooth_Change()
    If (Trim(txtSmooth.Text) = "") Then txtSmooth.Text = 2
End Sub

Private Sub txtSmooth_KeyPress(KeyAscii As Integer)
    If (KeyAscii > Asc("9")) Or (KeyAscii < Asc("0")) Then
        If (KeyAscii <> vbKeyBack) And (KeyAscii <> Asc(".")) Then
            KeyAscii = 0
            Beep
        End If
    End If
End Sub