frm3dwizard.frm

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

VERSION 5.00
Begin VB.Form frmtoTin 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "生成Tin"
   ClientHeight    =   3000
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5790
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3000
   ScaleWidth      =   5790
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.Frame Frame2 
      Caption         =   "设置"
      Height          =   1470
      Left            =   255
      TabIndex        =   7
      Top             =   1380
      Width           =   3495
      Begin VB.ComboBox cmbFieldZ 
         Height          =   315
         Left            =   1335
         Style           =   2  'Dropdown List
         TabIndex        =   10
         Top             =   270
         Width           =   2025
      End
      Begin VB.TextBox txtLen 
         Height          =   315
         Left            =   1335
         TabIndex        =   9
         Text            =   "10"
         Top             =   675
         Width           =   2025
      End
      Begin VB.TextBox txtScaleZ 
         Height          =   315
         Left            =   1335
         TabIndex        =   8
         Text            =   "1"
         Top             =   1065
         Width           =   2025
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         Caption         =   "伸 缩 比 例"
         Height          =   195
         Left            =   195
         TabIndex        =   13
         Tag             =   "3104"
         Top             =   1125
         Width           =   855
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         Caption         =   "高 程 字 段"
         Height          =   195
         Left            =   195
         TabIndex        =   12
         Tag             =   "5296"
         Top             =   330
         Width           =   855
      End
      Begin VB.Label Label2 
         AutoSize        =   -1  'True
         BackColor       =   &H8000000A&
         Caption         =   "重采样距离"
         Height          =   195
         Left            =   195
         TabIndex        =   11
         Tag             =   "3054"
         Top             =   735
         Width           =   900
      End
   End
   Begin VB.Frame Frame1 
      Caption         =   "保存生成的Tin 到"
      Height          =   1155
      Left            =   255
      TabIndex        =   4
      Tag             =   "3046"
      Top             =   120
      Width           =   3495
      Begin VB.ComboBox cmbDSName 
         Height          =   315
         Left            =   1395
         Style           =   2  'Dropdown List
         TabIndex        =   0
         ToolTipText     =   "存放TIN图层的数据源"
         Top             =   270
         Width           =   1935
      End
      Begin VB.TextBox txtTINName 
         Height          =   315
         Left            =   1395
         TabIndex        =   1
         Top             =   690
         Width           =   1935
      End
      Begin VB.Label lblDSName 
         AutoSize        =   -1  'True
         Caption         =   "数  据  源"
         Height          =   195
         Left            =   270
         TabIndex        =   6
         Tag             =   "3051"
         Top             =   330
         Width           =   720
      End
      Begin VB.Label lblTINName 
         AutoSize        =   -1  'True
         Caption         =   "Tin 的名称"
         Height          =   195
         Left            =   270
         TabIndex        =   5
         Tag             =   "3052"
         Top             =   765
         Width           =   810
      End
   End
   Begin VB.CommandButton btnCancel 
      Caption         =   "放弃(&C)"
      Height          =   405
      Left            =   4125
      TabIndex        =   3
      Tag             =   "3058"
      Top             =   735
      Width           =   1410
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "确定(&O)"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   405
      Left            =   4125
      TabIndex        =   2
      Tag             =   "3057"
      Top             =   225
      Width           =   1410
   End
End
Attribute VB_Name = "frmtoTin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'iWhat 取不同的值表示进行不同的操作；
'iWhat=1表示等高线 --->TIN；
'iWhat=2表示点-------->TIN；
'iWhat=3表示三维点---->TIN；
Option Explicit

Public iWhat As Integer

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

Private Sub btnOK_Click()         '确定
    Dim DS As soDataSource
    Dim Dt As soDataset
    Dim obj3DAnalyst As New so3DAnalyst
    
    Dim dLen As Double
    Dim dScale As Double
    Dim strSelect As String
    Dim bResult As Boolean
    Dim strDtName As String
    
    '获得源数据源和数据集信息
    strSelect = frmMain.tvwDataSource.SelectedItem.Parent.Text            '获得数据源名称
    Set DS = frmMain.SuperWorkspace.Datasources.Item(strSelect)           '获得源数据源
    If DS Is Nothing Then
        MsgBox "打开源数据源失败!", vbInformation
        Exit Sub
    End If
    
    Set Dt = DS.Datasets.Item(frmMain.tvwDataSource.SelectedItem.Text)
    If Dt Is Nothing Then
        MsgBox "打开源数据集失败!", vbInformation
        Exit Sub
    End If
    
    '获得目标数据源和数据集信息
    Set DS = frmMain.SuperWorkspace.Datasources.Item(cmbDsName.Text)   '获得数据源
    If DS Is Nothing Then
        MsgBox "打开数据源失败!", vbInformation
        Exit Sub
    End If
    
    strDtName = txtTINName.Text
    If (DS.IsAvailableDatasetName(strDtName)) = False Then
        MsgBox "Tin数据集名不合法!", vbInformation
        Exit Sub
    End If
    
    strSelect = Trim(txtLen.Text)
    If strSelect = "" Then
        MsgBox "请设置合理的重采样值", vbInformation
        Exit Sub
    Else
        dLen = CDbl(txtLen.Text)
    End If
    
    strSelect = Trim(txtScaleZ.Text)
    If strSelect = "" Then
        dScale = 0
    Else
        dScale = CDbl(strSelect)
        If dScale > 20 Then
            dScale = 20
        ElseIf dScale < 0 Then
            dScale = 20
        End If
    End If
    
    Select Case iWhat
        Case 1      '"三维窗口：等高线 -> TIN"
            bResult = obj3DAnalyst.LineToTIN(Dt, cmbFieldZ.Text, DS, strDtName, dLen, dScale, True)
            If bResult Then
                frmMain.tvwDataSource.Nodes.Add DS.Alias, tvwChild, , strDtName, 14
            Else
                MsgBox "由等高线生成Tin数据集失败!", vbInformation
            End If
        Case 2       '"三维窗口：点->TIN"
            bResult = obj3DAnalyst.PointToTIN(Dt, cmbFieldZ.Text, DS, strDtName, dScale, True)
            If bResult Then
                frmMain.tvwDataSource.Nodes.Add DS.Alias, tvwChild, , strDtName, 14
            Else
                MsgBox "由二维点生成Tin数据集失败!", vbInformation
            End If
        Case 3      '"三维窗口：三维点->TIN"
            bResult = obj3DAnalyst.Point3DToTIN(Dt, DS, strDtName, dScale, True)
            If bResult Then
                frmMain.tvwDataSource.Nodes.Add DS.Alias, tvwChild, , strDtName, 14
            Else
                MsgBox "由三维点生成Tin数据集失败!", vbInformation
            End If
    End Select
    
    Unload Me
End Sub

Private Sub Form_Load()
    Dim DS As soDataSource
    Dim DtVector As soDatasetVector
    Dim FieldInfo As soFieldInfo
    Dim FieldType As seFieldType
    Dim i As Integer, lFieldCount As Long
    Dim strSelect As String
    
    strSelect = frmMain.tvwDataSource.SelectedItem.Parent.Text    '获取数据源名称
    Set DS = frmMain.SuperWorkspace.Datasources.Item(strSelect)   '获取数据源
    If DS Is Nothing Then
        MsgBox "打开数据源失败!", vbInformation
        Exit Sub
    End If
    
    strSelect = frmMain.tvwDataSource.SelectedItem.Text           '获取数据集名称
    Set DtVector = DS.Datasets.Item(strSelect)                    '获取数据集
    If DtVector Is Nothing Then
        MsgBox "打开数据集失败!", vbInformation
        Exit Sub
    End If
    
    For Each DS In frmMain.SuperWorkspace.Datasources             '添加数据源列表
        cmbDsName.AddItem DS.Alias
    Next
    cmbDsName.ListIndex = -1
    
    lFieldCount = DtVector.FieldCount
    For i = 1 To lFieldCount
        Set FieldInfo = DtVector.GetFieldInfo(i)  '获取字段值
        FieldType = FieldInfo.Type
        If FieldType = scfDouble Or FieldType = scfInteger Or FieldType = scfLong Or FieldType = scfSingle Then '只有数值型字段才可以用作建模
            cmbFieldZ.AddItem FieldInfo.Name       '添加高程字段列表
        End If
    Next
    cmbFieldZ.ListIndex = -1
    
    txtLen.Text = "20"                             '重采样距离
    txtScaleZ.Text = "1.0"                         '高程伸缩
End Sub

Private Sub txtLen_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 txtScaleZ_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 txtTINName_Change() '判断是否已经给TIN赋名称
    If Trim$(txtTINName.Text) <> "" Then btnOK.Enabled = True
End Sub

Private Sub txtTINName_LostFocus()
    If Trim$(txtTINName.Text) = "" Then btnOK.Enabled = False
End Sub