frmtintocontour.frm

都是基于VB所做的程序集合,值得大家作为实践的参考资料.

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frmTinToContour 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Tin -> 等高线"
   ClientHeight    =   3480
   ClientLeft      =   2760
   ClientTop       =   3750
   ClientWidth     =   6645
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3480
   ScaleWidth      =   6645
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.Frame Frame3 
      Caption         =   "源数据集"
      Height          =   720
      Left            =   105
      TabIndex        =   11
      Tag             =   "3087"
      Top             =   180
      Width           =   5265
      Begin VB.Label lblSourceDtName 
         BackColor       =   &H00E0FEFB&
         BorderStyle     =   1  'Fixed Single
         Height          =   315
         Left            =   3630
         TabIndex        =   15
         Top             =   225
         Width           =   1470
      End
      Begin VB.Label lblSourceDsName 
         BackColor       =   &H00E0FEFB&
         BorderStyle     =   1  'Fixed Single
         Height          =   315
         Left            =   1035
         TabIndex        =   14
         Top             =   255
         Width           =   1470
      End
      Begin VB.Label Label4 
         Caption         =   "数据源名称"
         Height          =   240
         Left            =   120
         TabIndex        =   13
         Tag             =   "3051"
         Top             =   330
         Width           =   915
      End
      Begin VB.Label Label5 
         Caption         =   "数据集名称"
         Height          =   240
         Left            =   2685
         TabIndex        =   12
         Tag             =   "3052"
         Top             =   285
         Width           =   900
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "目标数据集"
      Height          =   720
      Left            =   105
      TabIndex        =   6
      Tag             =   "3050"
      Top             =   997
      Width           =   5265
      Begin VB.TextBox txtDtName 
         Height          =   315
         Left            =   3645
         TabIndex        =   8
         Top             =   255
         Width           =   1470
      End
      Begin VB.ComboBox cmbDsName 
         Height          =   315
         Left            =   1035
         Style           =   2  'Dropdown List
         TabIndex        =   7
         Top             =   255
         Width           =   1470
      End
      Begin VB.Label Label2 
         Caption         =   "数据集名称"
         Height          =   255
         Left            =   2655
         TabIndex        =   10
         Tag             =   "3052"
         Top             =   315
         Width           =   900
      End
      Begin VB.Label Label1 
         Caption         =   "数据源名称"
         Height          =   255
         Left            =   105
         TabIndex        =   9
         Tag             =   "3051"
         Top             =   315
         Width           =   1020
      End
   End
   Begin VB.Frame framOption 
      Caption         =   "选项"
      Height          =   1560
      Left            =   105
      TabIndex        =   2
      Tag             =   "3071"
      Top             =   1815
      Width           =   5265
      Begin VB.Frame Frame2 
         Height          =   720
         Left            =   180
         TabIndex        =   16
         Top             =   255
         Width           =   4890
         Begin MSComCtl2.UpDown UpDown1 
            Height          =   270
            Left            =   1755
            TabIndex        =   17
            Top             =   285
            Width           =   240
            _ExtentX        =   423
            _ExtentY        =   476
            _Version        =   393216
            Value           =   10
            BuddyControl    =   "txtDistance"
            BuddyDispid     =   196621
            OrigLeft        =   1455
            OrigTop         =   285
            OrigRight       =   1695
            OrigBottom      =   555
            Max             =   100
            Min             =   1
            SyncBuddy       =   -1  'True
            BuddyProperty   =   65547
            Enabled         =   -1  'True
         End
         Begin MSComCtl2.UpDown UpDown2 
            Height          =   270
            Left            =   4350
            TabIndex        =   23
            Top             =   285
            Width           =   240
            _ExtentX        =   423
            _ExtentY        =   476
            _Version        =   393216
            Value           =   44
            BuddyControl    =   "txtContourCount"
            BuddyDispid     =   196622
            OrigLeft        =   4320
            OrigTop         =   285
            OrigRight       =   4560
            OrigBottom      =   555
            Max             =   1000
            Min             =   2
            SyncBuddy       =   -1  'True
            BuddyProperty   =   65547
            Enabled         =   -1  'True
         End
         Begin VB.TextBox txtDistance 
            Height          =   315
            Left            =   795
            TabIndex        =   18
            Top             =   255
            Width           =   1230
         End
         Begin VB.TextBox txtContourCount 
            Height          =   315
            Left            =   3690
            TabIndex        =   22
            Top             =   255
            Width           =   930
         End
         Begin VB.Label Label3 
            Caption         =   "等高线条数"
            Height          =   240
            Left            =   2685
            TabIndex        =   21
            Top             =   315
            Width           =   990
         End
         Begin VB.Label lblDistance 
            Caption         =   "等高距"
            Height          =   240
            Left            =   120
            TabIndex        =   20
            Tag             =   "5350"
            Top             =   315
            Width           =   645
         End
         Begin VB.Label lblUnit 
            Caption         =   "米"
            Height          =   210
            Left            =   2085
            TabIndex        =   19
            Tag             =   "5026"
            Top             =   315
            Width           =   375
         End
      End
      Begin VB.ComboBox cmbSmoothmess 
         Height          =   315
         Left            =   975
         Style           =   2  'Dropdown List
         TabIndex        =   3
         Top             =   1110
         Width           =   930
      End
      Begin VB.Label lblArcUnit 
         Caption         =   "级"
         Height          =   210
         Left            =   1995
         TabIndex        =   5
         Tag             =   "5371"
         Top             =   1170
         Width           =   270
      End
      Begin VB.Label lblArc 
         Caption         =   "光滑度"
         Height          =   240
         Left            =   300
         TabIndex        =   4
         Tag             =   "5370"
         Top             =   1185
         Width           =   570
      End
   End
   Begin VB.CommandButton btnCancel 
      Caption         =   "放弃(&C)"
      Height          =   375
      Left            =   5460
      TabIndex        =   1
      Top             =   780
      Width           =   1095
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "确定(&O)"
      Enabled         =   0   'False
      Height          =   375
      Left            =   5475
      TabIndex        =   0
      Top             =   270
      Width           =   1095
   End
End
Attribute VB_Name = "frmTinToContour"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Dim dMargin As Double

Private Sub btnCancel_Click()             '放弃
    Unload Me
End Sub

Private Sub btnOK_Click()                 '确定
    Dim strTinName As String
    Dim objDs As soDataSource
    Dim objDt1 As soDatasetVector
    Dim obj3DAnalyst As New so3DAnalyst
    Dim bResult As Boolean
    
    Dim strTemp As String
    
    '获得源数据集
    strTemp = lblSourceDsName.Caption
    Set objDs = frmMain.SuperWorkspace.Datasources(strTemp)
    If objDs Is Nothing Then
        MsgBox "获取源数据源失败", vbInformation
        Exit Sub
    End If
    
    strTemp = lblSourceDtName.Caption
    Set objDt1 = objDs.Datasets.Item(strTemp)
    If objDt1 Is Nothing Then
        MsgBox "获取源数据集失败", vbInformation
        Exit Sub
    End If
    
    '获得目标数据源和数据集的信息
    strTemp = cmbDsName.Text
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(strTemp)
    If objDs Is Nothing Then
        MsgBox "获取目标数据源失败", vbInformation
        Exit Sub
    End If
    
    strTinName = Trim$(txtDtName.Text)
    If objDs.IsAvailableDatasetName(strTinName) = False Then '判断数据集的名称在soDatasource对象中是否合法
        MsgBox "Tin数据集名称非法！", vbCritical
        Exit Sub
    End If
    
    bResult = obj3DAnalyst.TINToContour(objDt1, objDs, strTinName, CDbl(Val(txtDistance.Text)), CLng(Val(cmbSmoothmess.Text)))
    If bResult = True Then
        '添加新创建的等高线数据集
        frmMain.tvwDataSource.Nodes.Add objDs.Alias, tvwChild, , strTinName, 5
        Unload Me
    Else
        MsgBox "转换失败", vbCritical
    End If
    
    Set obj3DAnalyst = Nothing
End Sub

Private Sub Form_Load()
    Dim objDs As soDataSource
    Dim objDtVector As soDatasetVector
    Dim strName As String
    Dim i As Integer
    
    '将当前工作空间中的数据源都添加到目标数据源列表中
    cmbDsName.Clear
    For Each objDs In frmMain.SuperWorkspace.Datasources
        cmbDsName.AddItem objDs.Alias
    Next
    cmbDsName.ListIndex = -1
    
    '将当前数据集所在的数据源的名称设置到源数据源信息框中
    strName = frmMain.tvwDataSource.SelectedItem.Parent.Text
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(strName)
    
    '将当前数据集的名称设置到源数据集信息框中
    lblSourceDsName.Caption = strName
    strName = frmMain.tvwDataSource.SelectedItem.Text
    lblSourceDtName.Caption = strName
    
    Set objDtVector = objDs.Datasets(strName)
    If Not (objDtVector Is Nothing) Then       '获得Tin数据集的高差
        dMargin = objDtVector.MaxZ() - objDtVector.MinZ()
    End If
    
    For i = 0 To 5
        cmbSmoothmess.AddItem i
    Next
    cmbSmoothmess.Text = "3"                   '默认光滑度值
    
    txtDistance.Text = 10#                     '默认等高距值
    
    Set objDs = Nothing
    Set objDtVector = Nothing
End Sub

Private Sub txtContourCount_Change()
    If Val(txtContourCount.Text) = 0 Then Exit Sub
    txtDistance.Text = Round(dMargin / Val(txtContourCount.Text), 3)
End Sub

Private Sub txtContourCount_KeyPress(KeyAscii As Integer)  '限定等高线条数
    If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
        If (KeyAscii <> vbKeyBack) Then
            KeyAscii = 0
            Beep
        End If
    End If
End Sub

Private Sub txtDistance_Change()
    If Val(txtDistance.Text) = 0 Then Exit Sub
    txtContourCount.Text = CInt(dMargin / Val(txtDistance.Text))
End Sub

Private Sub txtDistance_KeyPress(KeyAscii As Integer)      '限定等高距值
    If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
        If (KeyAscii <> vbKeyBack) Then
            KeyAscii = 0
            Beep
        End If
    End If
End Sub

Private Sub txtDtName_Change()
    txtDtName.Text = Trim$(txtDtName.Text)
        If Len(txtDtName.Text) > 0 Then
            btnOK.Enabled = True
        Else
            btnOK.Enabled = False
        End If
End Sub