frmvector2grid.frm

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

VERSION 5.00
Begin VB.Form frmVector2Grid 
   BackColor       =   &H8000000A&
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "矢量数据<-->栅格数据"
   ClientHeight    =   4395
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6735
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4395
   ScaleWidth      =   6735
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.CommandButton cmdOk 
      Caption         =   "确定"
      Height          =   435
      Left            =   2340
      TabIndex        =   22
      Top             =   3780
      Width           =   945
   End
   Begin VB.CommandButton cmdCancel 
      Caption         =   "取消"
      Height          =   435
      Left            =   3450
      TabIndex        =   21
      Top             =   3780
      Width           =   945
   End
   Begin VB.Frame Frame2 
      BackColor       =   &H8000000A&
      Caption         =   "参数设置"
      Height          =   2355
      Left            =   3360
      TabIndex        =   10
      Top             =   1260
      Width           =   3345
      Begin VB.TextBox txtPix 
         Height          =   315
         Left            =   1155
         TabIndex        =   20
         Text            =   "5"
         Top             =   1845
         Width           =   2100
      End
      Begin VB.ComboBox cmbPixFormat 
         Height          =   315
         Left            =   1155
         Style           =   2  'Dropdown List
         TabIndex        =   19
         Top             =   1449
         Width           =   2100
      End
      Begin VB.ComboBox cmbField 
         Height          =   315
         Left            =   1155
         Style           =   2  'Dropdown List
         TabIndex        =   18
         Top             =   1056
         Width           =   2100
      End
      Begin VB.ComboBox cmbDtList2 
         Height          =   315
         Left            =   1155
         Style           =   2  'Dropdown List
         TabIndex        =   17
         Top             =   663
         Width           =   2100
      End
      Begin VB.ComboBox cmbDsList2 
         Height          =   315
         Left            =   1155
         Style           =   2  'Dropdown List
         TabIndex        =   16
         Top             =   270
         Width           =   2100
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "分辨率："
         Height          =   195
         Index           =   8
         Left            =   465
         TabIndex        =   15
         Top             =   1890
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "象素类型："
         Height          =   195
         Index           =   5
         Left            =   285
         TabIndex        =   14
         Top             =   1503
         Width           =   900
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "高程字段："
         Height          =   195
         Index           =   4
         Left            =   285
         TabIndex        =   13
         Top             =   1110
         Width           =   900
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "边界数据集："
         Height          =   195
         Index           =   3
         Left            =   105
         TabIndex        =   12
         Top             =   731
         Width           =   1080
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "数据源："
         Height          =   195
         Index           =   2
         Left            =   465
         TabIndex        =   11
         Top             =   345
         Width           =   720
      End
   End
   Begin VB.Frame Frame1 
      BackColor       =   &H8000000A&
      Caption         =   "需要转换的矢量数据"
      Height          =   1170
      Left            =   45
      TabIndex        =   5
      Top             =   1260
      Width           =   3285
      Begin VB.ComboBox cmbDtList 
         Height          =   315
         Left            =   1095
         Style           =   2  'Dropdown List
         TabIndex        =   7
         Top             =   705
         Width           =   2100
      End
      Begin VB.ComboBox cmbDsList 
         Height          =   315
         Left            =   1095
         Style           =   2  'Dropdown List
         TabIndex        =   6
         Top             =   255
         Width           =   2100
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "数据集："
         Height          =   195
         Index           =   1
         Left            =   340
         TabIndex        =   9
         Top             =   705
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "数据源："
         Height          =   195
         Index           =   0
         Left            =   340
         TabIndex        =   8
         Top             =   330
         Width           =   720
      End
   End
   Begin VB.Frame Frame4 
      BackColor       =   &H8000000A&
      Caption         =   "结果数据集保存"
      Height          =   1140
      Left            =   45
      TabIndex        =   0
      Top             =   2475
      Width           =   3285
      Begin VB.ComboBox cmbDsListResult 
         Height          =   315
         Left            =   1095
         Style           =   2  'Dropdown List
         TabIndex        =   2
         Top             =   285
         Width           =   2070
      End
      Begin VB.TextBox txtDataset 
         Height          =   315
         Left            =   1095
         TabIndex        =   1
         Text            =   "Raster"
         Top             =   675
         Width           =   2070
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "数据集："
         Height          =   195
         Index           =   7
         Left            =   340
         TabIndex        =   4
         Top             =   705
         Width           =   720
      End
      Begin VB.Label Label1 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "数据源："
         Height          =   195
         Index           =   6
         Left            =   340
         TabIndex        =   3
         Top             =   330
         Width           =   720
      End
   End
   Begin VB.Image Image1 
      Appearance      =   0  'Flat
      BorderStyle     =   1  'Fixed Single
      Height          =   1200
      Left            =   15
      Picture         =   "frmVector2Grid.frx":0000
      Stretch         =   -1  'True
      Top             =   0
      Width           =   6720
   End
End
Attribute VB_Name = "frmVector2Grid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public iChangeType As Integer

Private Sub cmbDsList_Click()
    If cmbDsList.Text = "" Then Exit Sub
    If frmMain.bActiveFrm Then
        If iChangeType = 1 Then
            ChangeDs cmbDsList.Text, cmbDtList
        ElseIf iChangeType = 2 Then
            GetVector cmbDsList.Text, cmbDtList
        End If
    End If
End Sub

Private Sub cmbDsList2_Click()
    If iChangeType = 1 Then Exit Sub
    If cmbDsList2.Text = "" Then Exit Sub
    If frmMain.bActiveFrm Then
        ChangeDs2 cmbDsList2.Text, cmbDtList2
    End If
End Sub

Private Sub cmbDtList_Click()
    If iChangeType = 1 Then Exit Sub
    If cmbDtList.Text = "" Then Exit Sub
    If frmMain.bActiveFrm Then
        ChangeDt cmbDsList.Text, cmbDtList.Text, cmbField
    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 objDtv As soDatasetVector
    Dim objRect As soRect
    Dim objGridAnalystEx As soGridAnalystEx
    Dim objConverOperator As soConversionOperator
    Dim myPixelFormat As sePixelFormat
    Dim strTmp As String
    
    
    Set objDs = frmMain.SuperWorkspace.Datasources(cmbDsList.Text)
    If iChangeType = 1 Then
        Set objDtRst = objDs.Datasets(cmbDtList.Text)
    ElseIf iChangeType = 2 Then
        Set objDtv = objDs.Datasets(cmbDtList.Text)
    End If
    Set objDs = frmMain.SuperWorkspace.Datasources(cmbDsListResult.Text)
    strTmp = DataSetName(objDs, txtDataset.Text)
    If strTmp <> "" Then
        Set objGridAnalystEx = frmMain.SuperAnalyst.GridAnalyst
        Set objConverOperator = objGridAnalystEx.Conversion
        If iChangeType = 1 Then
            Set objDtv = objConverOperator.RasterToVector(objDtRst, scdRegion, objDs, strTmp)
            If objDtv Is Nothing Then
                MsgBox "栅格生成矢量数据失败", vbInformation, "信息提示"
            End If
        ElseIf iChangeType = 2 Then
            myPixelFormat = GetPixFrmByIndex(cmbPixFormat.ListIndex)
            Set objRect = GetBounds(cmbDsList2.Text, cmbDtList2.Text)
            Set objDtRst = objConverOperator.VectorToRaster(objDtv, cmbField.Text, objRect, CInt(txtPix.Text), myPixelFormat, objDs, strTmp)
            If objDtRst Is Nothing Then
                MsgBox "矢量生成栅格数据失败", vbInformation, "信息提示"
            End If
        End If
        frmMain.SuperWkspManager.Refresh
        
        Set objRect = Nothing
        Set objDtRst = Nothing
        Set objDtv = Nothing
        Set objDs = Nothing
        Set objGridAnalystEx = Nothing
        Set objConverOperator = Nothing
        Unload Me
    Else
        txtDataset.Text = ""
        txtDataset.SetFocus
    End If
    
    Set objRect = Nothing
    Set objDtv = Nothing
    Set objDtRst = Nothing
    Set objDs = Nothing
    Set objGridAnalystEx = Nothing
    Set objConverOperator = Nothing
End Sub

Private Sub Form_Activate()
    frmMain.bActiveFrm = True
    cmbDsList_Click
    cmbDsList2_Click
    If iChangeType = 1 Then
        Frame1.Caption = "需要转换的栅格数据集"
    Else
        Frame1.Caption = "需要转换的矢量数据集"
    End If
    
End Sub

Private Sub Form_Load()
    IniPixFormat
End Sub

Public Sub IniPixFormat()
    cmbPixFormat.Clear
    cmbPixFormat.AddItem "单色/黑白影像"
    cmbPixFormat.AddItem "16色影像"
    cmbPixFormat.AddItem "256色影像"
    cmbPixFormat.AddItem "16位彩色影像"
    cmbPixFormat.AddItem "24位真彩色影像"
    cmbPixFormat.AddItem "32位增强真色影像"
    cmbPixFormat.AddItem "64位整型 GIRD"
    cmbPixFormat.AddItem "32位整型 GRI"
    cmbPixFormat.AddItem "单精度浮点 GRID"
    cmbPixFormat.AddItem "双精度浮点 GRID"
    cmbPixFormat.ListIndex = 5
End Sub

Private Sub txtPix_Change()
    If Trim(txtPix.Text) = "" Then txtPix.Text = "5"
    If Trim(txtPix.Text) = "0" Then txtPix.Text = 5
End Sub

Private Sub txtPix_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 Function GetPixFrmByIndex(nIndex As Integer) As sePixelFormat
    Dim nPixelFormat As sePixelFormat
    Select Case nIndex
        Case 0
            nPixelFormat = scpMono
        Case 1
            nPixelFormat = scpFBit
        Case 2
            nPixelFormat = scpByte
        Case 3
            nPixelFormat = scpTByte
        Case 4
            nPixelFormat = scpRGB
        Case 5
            nPixelFormat = scpRGBA
        Case 6
            nPixelFormat = scpLongLong
        Case 7
            nPixelFormat = scpLong
        Case 8
            nPixelFormat = scpFloat
        Case 9
            nPixelFormat = scpDouble
    End Select
    GetPixFrmByIndex = nPixelFormat
End Function

Private Function GetBounds(strDs As String, strDt As String) As soRect
    Dim objDt As soDataset
    Dim objDs As soDataSource
    
    Set objDs = frmMain.SuperWorkspace.Datasources(strDs)
    Set objDt = objDs.Datasets(strDt)
    Set GetBounds = objDt.Bounds
    
    Set objDs = Nothing
    Set objDt = Nothing
End Function

Private Sub GetVector(strDs As String, objCmb As ComboBox)
    Dim strDt As String
    Dim objDs As soDataSource
    Dim objDt As soDataset
    Dim i As Integer
    Dim iCnt As Integer
    
    Set objDs = frmMain.SuperWorkspace.Datasources(strDs)
    If Not objDs Is Nothing Then
        iCnt = objDs.Datasets.Count
        If iCnt > 0 Then
            objCmb.Clear
            For i = 1 To iCnt
                Set objDt = objDs.Datasets(i)
                If objDt.Type = scdLine Or objDt.Type = scdPoint Or objDt.Type = scdRegion Then
                    strDt = objDt.Name
                    objCmb.AddItem strDt
                End If
            Next i
        Else
            objCmb.Clear
        End If
        If objCmb.ListCount > 0 Then objCmb.ListIndex = 0
        objCmb.Refresh
    Else
        MsgBox "获取数据源失败", vbInformation, "信息提示"
    End If
    Set objDt = Nothing
    Set objDs = Nothing
End Sub