frmtogrid.frm

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

VERSION 5.00
Begin VB.Form frmtoGrid 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "ToGrid转换"
   ClientHeight    =   4290
   ClientLeft      =   30
   ClientTop       =   330
   ClientWidth     =   3945
   Icon            =   "frmtoGrid.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4290
   ScaleWidth      =   3945
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Begin VB.Frame Frame2 
      Caption         =   "类型"
      Height          =   1545
      Left            =   150
      TabIndex        =   18
      Top             =   1320
      Width           =   1095
      Begin VB.OptionButton OptElevation 
         Caption         =   "高程"
         Height          =   247
         Left            =   195
         TabIndex        =   21
         Top             =   1110
         Width           =   720
      End
      Begin VB.OptionButton OptAspect 
         Caption         =   "坡向"
         Height          =   247
         Left            =   195
         TabIndex        =   20
         Top             =   705
         Width           =   720
      End
      Begin VB.OptionButton OptSlope 
         Caption         =   "坡度"
         Height          =   247
         Left            =   195
         TabIndex        =   19
         Top             =   285
         Value           =   -1  'True
         Width           =   720
      End
   End
   Begin VB.TextBox TxtDtNameTar 
      Height          =   315
      Left            =   1245
      TabIndex        =   17
      Top             =   3360
      Width           =   2610
   End
   Begin VB.Frame Frame1 
      Caption         =   "参数设置"
      Height          =   1545
      Left            =   1335
      TabIndex        =   13
      Top             =   1320
      Width           =   2520
      Begin VB.ComboBox cmbField 
         Height          =   315
         Left            =   1155
         Style           =   2  'Dropdown List
         TabIndex        =   23
         Top             =   615
         Width           =   1125
      End
      Begin VB.CheckBox ChkProgress 
         Alignment       =   1  'Right Justify
         Caption         =   "显示进度条"
         Height          =   364
         Left            =   135
         TabIndex        =   16
         Top             =   1005
         Width           =   1215
      End
      Begin VB.TextBox TxtResolution 
         Height          =   315
         Left            =   1140
         TabIndex        =   14
         Top             =   210
         Width           =   1125
      End
      Begin VB.Label Label6 
         AutoSize        =   -1  'True
         Caption         =   "高程字段"
         Height          =   195
         Left            =   360
         TabIndex        =   22
         Top             =   690
         Width           =   720
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         Caption         =   "分辨率"
         Height          =   195
         Left            =   540
         TabIndex        =   15
         Top             =   315
         Width           =   540
      End
   End
   Begin VB.CommandButton btnCancel 
      Caption         =   "取消"
      Height          =   364
      Left            =   2535
      TabIndex        =   12
      Top             =   3840
      Width           =   1183
   End
   Begin VB.CommandButton btnOk 
      Caption         =   "确定"
      Height          =   364
      Left            =   1245
      TabIndex        =   11
      Top             =   3840
      Width           =   1183
   End
   Begin VB.ComboBox CmbDtNameSrc 
      Height          =   315
      Left            =   1245
      Style           =   2  'Dropdown List
      TabIndex        =   6
      Top             =   930
      Width           =   2610
   End
   Begin VB.ComboBox CmbDsNameTar 
      Height          =   315
      Left            =   1245
      Style           =   2  'Dropdown List
      TabIndex        =   5
      Top             =   2970
      Width           =   2610
   End
   Begin VB.ComboBox CmbDsNameSrc 
      Height          =   315
      Left            =   1245
      Style           =   2  'Dropdown List
      TabIndex        =   4
      Top             =   420
      Width           =   2610
   End
   Begin VB.OptionButton OptLine 
      Caption         =   "Line"
      Height          =   247
      Left            =   2055
      TabIndex        =   3
      Top             =   105
      Width           =   750
   End
   Begin VB.OptionButton OptRegion 
      Caption         =   "Region"
      Height          =   247
      Left            =   2955
      TabIndex        =   2
      Top             =   105
      Width           =   975
   End
   Begin VB.OptionButton OptTin 
      Caption         =   "TIN"
      Height          =   247
      Left            =   1230
      TabIndex        =   1
      Top             =   105
      Width           =   675
   End
   Begin VB.OptionButton Opt3D 
      Caption         =   "3D点"
      Height          =   247
      Left            =   180
      TabIndex        =   0
      Top             =   105
      Value           =   -1  'True
      Width           =   900
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      Caption         =   "输出数据集"
      Height          =   195
      Left            =   195
      TabIndex        =   10
      Top             =   3390
      Width           =   900
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      Caption         =   "输出数据源"
      Height          =   195
      Left            =   195
      TabIndex        =   9
      Top             =   3000
      Width           =   900
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "输入数据集"
      Height          =   195
      Left            =   195
      TabIndex        =   8
      Top             =   930
      Width           =   900
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "输入数据源"
      Height          =   195
      Left            =   195
      TabIndex        =   7
      Top             =   465
      Width           =   900
   End
End
Attribute VB_Name = "frmtoGrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim bProgress As Boolean
Dim iGridValueMode As Integer

Private Sub btnCancel_Click()
    Unload Me
End Sub

Private Sub chkProgress_Click()
    If ChkProgress.Value = vbChecked Then
        bProgress = True
    Else
        bProgress = False
    End If
End Sub


Private Sub cmbDsNameSrc_Click()
    Dim objDS As soDataSource
    Dim objDT As soDataset
    Dim objDtv As soDatasetVector
    Dim objFieldinfo As soFieldInfo
    Dim strName As String
    Dim objType As seDatasetType
    
    strName = CmbDsNameSrc.Text
    If strName = "" Then
        MsgBox "请选择输入的数据源", vbInformation
        Exit Sub
    End If
    Set objDS = frmGridAnalyst.SuperWorkspace1.Datasources.Item(strName)
    
    CmbDtNameSrc.Clear
    If Opt3D.Value Then
        objType = scdPointZ
    End If
    If OptTin.Value Then
        objType = scdTIN
    End If
    If OptLine.Value Then
        objType = scdLine
    End If
    If OptRegion.Value Then
        objType = scdRegion
    End If
    
    For Each objDT In objDS.Datasets
        If objDT.Type = objType Then
            CmbDtNameSrc.AddItem (objDT.Name)
        End If
    Next
    If CmbDtNameSrc.ListCount > 0 Then CmbDtNameSrc.ListIndex = 0
    
    
    Set objDS = Nothing
    Set objDT = Nothing
    Set objDtv = Nothing
    Set objFieldinfo = Nothing
End Sub

Private Sub cmbDtNameSrc_Click()
    Dim objDS As soDataSource
    Dim objDtv As soDatasetVector
    Dim objFieldinfo As soFieldInfo
    
    Set objDS = frmGridAnalyst.SuperWorkspace1.Datasources(CmbDsNameSrc.Text)
    If (objDS Is Nothing) Then Exit Sub
    Set objDtv = objDS.Datasets(CmbDtNameSrc.Text)
    If (objDtv Is Nothing) Then Exit Sub
    cmbField.Clear
    For Each objFieldinfo In objDtv.GetFieldInfos()
        If objFieldinfo.Type = scfDouble Or objFieldinfo.Type = scfSingle Or objFieldinfo.Type = scfInteger Or objFieldinfo.Type = scfLong Then
            cmbField.AddItem objFieldinfo.Name
        End If
    Next
    If cmbField.ListCount > 0 Then cmbField.ListIndex = 0
    TxtResolution = objDtv.Bounds.Width / 800
End Sub

Private Sub Form_Load()
    Dim objDS As soDataSource
    Dim strName As String
    
    bProgress = False
    For Each objDS In frmGridAnalyst.SuperWorkspace1.Datasources
        CmbDsNameSrc.AddItem objDS.Alias
        CmbDsNameTar.AddItem objDS.Alias
    Next
    If CmbDsNameSrc.ListCount > 0 Then CmbDsNameSrc.ListIndex = 0
    If CmbDsNameTar.ListCount > 0 Then CmbDsNameTar.ListIndex = 0
    
    Set objDS = Nothing
End Sub

Private Sub btnOk_Click()
    
    Dim objDSSrc As soDataSource    '源数据源
    Dim objDSTar As soDataSource    '源数据集
    Dim objDtSrc As soDataset       '目标数据源
    Dim objDtTar As soDatasetVector
    
    Dim objGridAnalyst As New soGridAnalyst
    Dim bResult As Boolean
    
    If Trim(TxtResolution) = "" Then
        MsgBox "请设置生成Grid的分辨率！", vbInformation
        TxtResolution.SetFocus
        Exit Sub
    End If
    
    Set objDSSrc = frmGridAnalyst.SuperWorkspace1.Datasources.Item(CmbDsNameSrc.Text)
    If (objDSSrc Is Nothing) Then
        MsgBox "数据源" & CmbDsNameSrc.Text & "有错误！", vbInformation
        Exit Sub
    End If
    
    Set objDtSrc = objDSSrc.Datasets.Item(CmbDtNameSrc.Text)
    If objDtSrc Is Nothing Then
        MsgBox "数据集" & CmbDtNameSrc.Text & "有错误！", vbInformation
        Exit Sub
    End If
    
    '处理结果数据源、数据集
    Set objDSTar = frmGridAnalyst.SuperWorkspace1.Datasources.Item(CmbDsNameTar.Text)
    If objDSTar Is Nothing Then
        MsgBox "数据源" & CmbDsNameTar.Text & "有错误！", vbInformation
        Exit Sub
    End If
    If objDSTar.IsAvailableDatasetName(Trim$(TxtDtNameTar.Text)) = False Then
        Set objDSTar = Nothing
        MsgBox "数据集名称" & TxtDtNameTar.Text & "非法！", vbInformation
        TxtDtNameTar.SetFocus
        Exit Sub
    End If
    
    If Opt3D.Value = True Then
          bResult = objGridAnalyst.Point3DToGrid(objDtSrc, objDSTar, TxtDtNameTar.Text, CDbl(Val(TxtResolution.Text)), bProgress)
    ElseIf OptTin.Value = True Then
        bResult = objGridAnalyst.TINToGrid(objDtSrc, objDSTar, TxtDtNameTar.Text, CDbl(Val(TxtResolution.Text)), bProgress, iGridValueMode)
    ElseIf OptLine.Value = True Then
        bResult = objGridAnalyst.LineToDEM(objDtSrc, cmbField.Text, objDSTar, TxtDtNameTar.Text, CDbl(Val(TxtResolution.Text)), bProgress)
    ElseIf OptRegion.Value = True Then
        bResult = objGridAnalyst.RegionToGrid(objDtSrc, cmbField.Text, objDSTar, TxtDtNameTar.Text, CDbl(Val(TxtResolution.Text)), bProgress)
    End If
    
    
    If bResult = True Then
    frmGridAnalyst.SuperWkspManager1.Refresh
    Else
        MsgBox "Grid分析失败!", vbInformation
    End If
    
    Set objDSSrc = Nothing
    Set objDSTar = Nothing
    Set objDtSrc = Nothing
    Set objDtTar = Nothing
    Set objGridAnalyst = Nothing
    Unload Me

End Sub

Private Sub Opt3D_Click()
    cmbDsNameSrc_Click
    TxtResolution.Enabled = True
    OptSlope.Enabled = False
    OptAspect.Enabled = False
    OptElevation.Enabled = False
    
End Sub

Private Sub OptAspect_Click()
    iGridValueMode = 3
End Sub

Private Sub OptElevation_Click()
    iGridValueMode = 1
End Sub

Private Sub OptLine_Click()
    cmbDsNameSrc_Click
    OptSlope.Enabled = False
    OptAspect.Enabled = False
    TxtResolution.Enabled = True
    OptElevation.Enabled = False
End Sub

Private Sub OptRegion_Click()
    cmbDsNameSrc_Click
    TxtResolution.Enabled = True
    OptSlope.Enabled = False
    OptAspect.Enabled = False
    OptElevation.Enabled = False
End Sub

Private Sub OptSlope_Click()
    iGridValueMode = 2
End Sub

Private Sub OptTin_Click()
    cmbDsNameSrc_Click
    TxtResolution.Enabled = True
    OptSlope.Enabled = True
    OptAspect.Enabled = True
    OptElevation.Enabled = True
End Sub

Private Sub TxtDtNameTar_Change()
    TxtDtNameTar.Text = Trim$(TxtDtNameTar.Text)
    If Len(TxtDtNameTar.Text) > 0 Then
        btnOk.Enabled = True
    Else
        btnOk.Enabled = False
    End If
End Sub