frmobjmanipulate.frm

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

VERSION 5.00
Begin VB.Form frmObjManipulate 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "对象操作"
   ClientHeight    =   2640
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   3720
   Icon            =   "frmObjManipulate.frx":0000
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2640
   ScaleWidth      =   3720
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.CommandButton btnCancel 
      Cancel          =   -1  'True
      Caption         =   "取消"
      Height          =   375
      Left            =   2520
      TabIndex        =   9
      Tag             =   "3058"
      Top             =   2145
      Width           =   1110
   End
   Begin VB.CommandButton btmOK 
      Caption         =   "确定"
      Default         =   -1  'True
      Height          =   375
      Left            =   1230
      TabIndex        =   8
      Tag             =   "3057"
      Top             =   2145
      Width           =   1110
   End
   Begin VB.Frame Frame1 
      Caption         =   "请选择保存生成结果的数据集"
      Height          =   1935
      Left            =   150
      TabIndex        =   0
      Top             =   150
      Width           =   3480
      Begin VB.CheckBox chkDelSourceObj 
         Caption         =   "删除源对象"
         Height          =   255
         Left            =   180
         TabIndex        =   5
         Tag             =   "3211"
         Top             =   1530
         Width           =   1380
      End
      Begin VB.TextBox txtNewDtName 
         BackColor       =   &H8000000A&
         Enabled         =   0   'False
         Height          =   300
         Left            =   1515
         TabIndex        =   4
         Top             =   1155
         Width           =   1800
      End
      Begin VB.CheckBox chkNewDtName 
         Caption         =   "新数据集"
         Height          =   240
         Left            =   180
         TabIndex        =   3
         Tag             =   "3070"
         Top             =   1170
         Width           =   1065
      End
      Begin VB.ComboBox cmbDtName 
         Height          =   315
         Left            =   1515
         Style           =   2  'Dropdown List
         TabIndex        =   2
         Top             =   750
         Width           =   1800
      End
      Begin VB.ComboBox cmbDSName 
         Height          =   315
         Left            =   1515
         Style           =   2  'Dropdown List
         TabIndex        =   1
         Top             =   345
         Width           =   1800
      End
      Begin VB.Label Label2 
         Alignment       =   2  'Center
         Caption         =   "数  据  集"
         Height          =   225
         Left            =   180
         TabIndex        =   7
         Tag             =   "3052"
         Top             =   810
         Width           =   1065
      End
      Begin VB.Label Label1 
         Alignment       =   2  'Center
         Caption         =   "数  据  源"
         Height          =   225
         Left            =   180
         TabIndex        =   6
         Tag             =   "3051"
         Top             =   405
         Width           =   1065
      End
   End
End
Attribute VB_Name = "frmObjManipulate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'========================================================================================
'iManipulate 取不同值表示进行不同的对象操作，=1表示对象相并；=2表示对象相交；=3表示对象异或；
'=4表示对象克隆;=5表示类型转换：线 -> 面；=6表示类型转换：面 -> 线；=7表示分解复杂对象;=8表示连接线对象
'========================================================================================
Option Explicit
Public iManipulate As Integer

Private Sub btmOK_Click()
    Dim objDestDS As soDataSource                  '目标数据源
    Dim objDestDt As soDataset                     '目标数据集
    Dim objDestDtVector As soDatasetVector
    Dim objSourceGeoMetry As soGeometry            '第一个操作对象
    Dim objLine As soGeoLine
    Dim objRegion As soGeoRegion
    Dim objText As soGeoText
    Dim objPoint As soGeoPoint
    Dim objPoints As soPoints
    Dim objRecordset As soRecordset                 '源RecordSet
    Dim objDestRecordSet As soRecordset             '存放结果的RecordSet
    Dim i As Long
    Dim bFirst As Boolean
    Dim iImgIndex As Integer
    
    '判断数据集名称是否合法
    Set objDestDS = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsName.Text)
    If objDestDS Is Nothing Then
        MsgBox "打开数据源错误！", vbCritical      '打开数据源错误
        Exit Sub
    End If
    If chkNewDtName.Value = 1 Then                  '使用新数据集
        '判断数据集名称是否合法
        If objDestDS.IsAvailableDatasetName(txtNewDtName.Text) = False Then
            MsgBox "数据集名称非法！", vbInformation
            txtNewDtName.SetFocus
            Set objDestDS = Nothing
            Exit Sub
        Else
            Dim iDtType As Integer
            Select Case Me.iManipulate
                Case 5                        '"类型转换：线 -> 面"
                    iDtType = scdRegion
                Case 6                        '"类型转换：面 -> 线"
                    iDtType = scdLine
                Case Else
                    iDtType = FrmMain.SuperMap1.selection.Dataset.Type
            End Select
            '创建新数据集
            Set objDestDt = objDestDS.CreateDataset(Trim$(txtNewDtName.Text), iDtType, 0)
            If objDestDt Is Nothing Then        '创建失败
                MsgBox "数据集创建失败!", vbInformation
                Set objDestDS = Nothing
                Set objDestDt = Nothing
                Exit Sub
            Else                                '创建成功
                '添加到主窗口的TreeView列表中
                Select Case objDestDt.Type
                    Case scdPoint
                        iImgIndex = 10
                    Case scdLine
                        iImgIndex = 12
                    Case scdRegion
                        iImgIndex = 4
                    Case scdText
                        iImgIndex = 11
                    Case scdCAD
                        iImgIndex = 13
                    Case scdNetwork
                        iImgIndex = 3
                    Case scdTIN
                        iImgIndex = 6
                    Case scdECW
                        iImgIndex = 16
                    Case scdMrSID
                        iImgIndex = 17
                    Case Else
                        iImgIndex = 7
                End Select

                    FrmMain.tvwData.Nodes.Add objDestDS.Alias, tvwChild, , Trim$(txtNewDtName.Text), iImgIndex
                    
                    cmbDtName.AddItem Trim$(txtNewDtName.Text)
                    cmbDtName.Text = Trim$(txtNewDtName.Text)
                    
                    Set objDestDtVector = objDestDS.Datasets.Item(Trim$(txtNewDtName.Text))
                    If objDestDtVector Is Nothing Then
                          MsgBox "数据集" & Trim$(txtNewDtName.Text) & "错误！", vbInformation
                          Exit Sub
                    End If
                    
                    Set objDestDS = Nothing
                    Set objDestDt = Nothing
            End If
        End If
    Else                                                                                                  '使用旧数据集
        If cmbDtName.Text = "" Then
              MsgBox "请给出数据集名称！", vbInformation
              Exit Sub
        End If
        Set objDestDtVector = objDestDS.Datasets.Item(cmbDtName.Text)
        If objDestDtVector Is Nothing Then
              MsgBox "数据集" & Trim$(cmbDtName.Text) & "错误，无法继续！", vbInformation
              Exit Sub
        End If
        Set objDestDS = Nothing
        Set objDestDt = Nothing
    End If
      
    '生成目标RecordSet
    objDestDtVector.Open
    Set objDestRecordSet = objDestDtVector.Query("", True)
    If objDestRecordSet Is Nothing Then
        MsgBox "错误！", vbInformation
        Exit Sub
    End If
    bFirst = True
    Set objRecordset = FrmMain.SuperMap1.selection.ToRecordset(False)
    If objRecordset Is Nothing Then
        MsgBox "所选对象的有关数据被损坏，无法继续!", vbCritical
        Set objDestRecordSet = Nothing
        Set objDestDtVector = Nothing
        Exit Sub
    End If
    objRecordset.MoveFirst
    '进行相交、相并、异或、类型转换（线->面、面->线）、克隆操作
    Dim nSelectCount As Long
    nSelectCount = FrmMain.SuperMap1.selection.Count
    Select Case iManipulate
        Case 1      '相并，线面文本对象有相并操作
            For i = 1 To nSelectCount
                '取操作数(几何对象)
                Set objSourceGeoMetry = objRecordset.GetGeometry()
                If objSourceGeoMetry Is Nothing Then
                    MsgBox "错误！", vbInformation
                    Exit Sub
                End If
                '判断几何对象的类型，分别处理
                Select Case objSourceGeoMetry.Type
                    Case scgLine
                        If bFirst Then
                            Set objLine = objSourceGeoMetry
                            If objLine Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                            End If
                            bFirst = False
                        Else
                            Set objLine = objLine.Union(objSourceGeoMetry)
                            If objLine Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                            End If
                        End If
                    Case scgRegion
                        If bFirst Then
                            Set objRegion = objSourceGeoMetry
                            If objRegion Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                            End If
                            bFirst = False
                        Else
                            Set objRegion = objRegion.Union(objSourceGeoMetry)
                            If objRegion Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                            End If
                        End If
                    Case scgText
                        If bFirst Then
                            Set objText = objSourceGeoMetry
                            If objText Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                            End If
                            bFirst = False
                        Else
                            Set objText = objText.Union(objSourceGeoMetry)
                            If objText Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                            End If
                        End If
                End Select
                objRecordset.MoveNext
            Next
            Set objSourceGeoMetry = Nothing
            If Not (objLine Is Nothing) Then
                objDestRecordSet.AddNew objLine
            ElseIf Not (objRegion Is Nothing) Then
                objDestRecordSet.AddNew objRegion
            ElseIf Not (objText Is Nothing) Then
                objDestRecordSet.AddNew objText
            End If
            objDestRecordSet.Update
        Case 2       '相交，只有线面两种类型的对象才有相交
            For i = 1 To nSelectCount
                Set objSourceGeoMetry = objRecordset.GetGeometry()
                If objSourceGeoMetry Is Nothing Then
                    MsgBox "错误！", vbInformation