frmclip.frm

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

VERSION 5.00
Begin VB.Form frmClip 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "裁剪数据集"
   ClientHeight    =   3345
   ClientLeft      =   2760
   ClientTop       =   3750
   ClientWidth     =   5760
   Icon            =   "frmClip.frx":0000
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3345
   ScaleWidth      =   5760
   ShowInTaskbar   =   0   'False
   StartUpPosition =   1  'CenterOwner
   Begin VB.Frame Frame1 
      Caption         =   "保存到"
      Height          =   2295
      Left            =   2490
      TabIndex        =   8
      Tag             =   "3050"
      Top             =   225
      Width           =   3135
      Begin VB.ComboBox cmbDSName 
         Height          =   315
         Left            =   1155
         Style           =   2  'Dropdown List
         TabIndex        =   12
         Top             =   360
         Width           =   1785
      End
      Begin VB.ComboBox cmbDtName 
         Height          =   315
         Left            =   1170
         Style           =   2  'Dropdown List
         TabIndex        =   11
         Top             =   840
         Width           =   1785
      End
      Begin VB.CheckBox chkNewDtName 
         Caption         =   "新的数据集"
         Height          =   225
         Left            =   165
         TabIndex        =   10
         Tag             =   "3070"
         Top             =   1470
         Width           =   2685
      End
      Begin VB.TextBox txtNewDtName 
         BackColor       =   &H80000004&
         Enabled         =   0   'False
         Height          =   285
         Left            =   420
         TabIndex        =   9
         Top             =   1785
         Width           =   2520
      End
      Begin VB.Label Label2 
         Caption         =   "数据源："
         Height          =   225
         Left            =   255
         TabIndex        =   14
         Tag             =   "3051"
         Top             =   435
         Width           =   885
      End
      Begin VB.Label Label3 
         Caption         =   "数据集："
         Height          =   225
         Left            =   255
         TabIndex        =   13
         Tag             =   "3052"
         Top             =   900
         Width           =   885
      End
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "裁剪(&O)"
      Default         =   -1  'True
      Height          =   405
      Left            =   975
      TabIndex        =   7
      Tag             =   "3057"
      Top             =   2850
      Width           =   1200
   End
   Begin VB.CommandButton btnCancel 
      Cancel          =   -1  'True
      Caption         =   "放弃(&C)"
      Height          =   405
      Left            =   3645
      TabIndex        =   6
      Tag             =   "3058"
      Top             =   2850
      Width           =   1200
   End
   Begin VB.Frame Frame3 
      Caption         =   "裁剪"
      Height          =   2295
      Left            =   135
      TabIndex        =   0
      Tag             =   "3065"
      Top             =   225
      Width           =   2235
      Begin VB.Frame Frame2 
         Caption         =   "选项"
         Height          =   1170
         Left            =   90
         TabIndex        =   1
         Tag             =   "5124"
         Top             =   1035
         Width           =   2055
         Begin VB.OptionButton optOut 
            Caption         =   "裁剪区域外的对象"
            Height          =   255
            Left            =   120
            TabIndex        =   3
            Tag             =   "3069"
            Top             =   720
            Width           =   1815
         End
         Begin VB.OptionButton optIn 
            Caption         =   "裁剪区域内的对象"
            Height          =   255
            Left            =   120
            TabIndex        =   2
            Tag             =   "3068"
            Top             =   375
            Value           =   -1  'True
            Width           =   1800
         End
      End
      Begin VB.Label lblSourceLayerName 
         BackColor       =   &H80000018&
         BorderStyle     =   1  'Fixed Single
         Height          =   315
         Left            =   150
         TabIndex        =   5
         Top             =   585
         Width           =   1965
      End
      Begin VB.Label Label1 
         Caption         =   "源图层名："
         Height          =   240
         Left            =   195
         TabIndex        =   4
         Tag             =   "3066"
         Top             =   315
         Width           =   1500
      End
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000005&
      X1              =   0
      X2              =   5835
      Y1              =   2715
      Y2              =   2715
   End
   Begin VB.Line Line2 
      X1              =   0
      X2              =   5835
      Y1              =   2700
      Y2              =   2700
   End
End
Attribute VB_Name = "frmClip"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim objError As soError

Private Sub btnCancel_Click()
    Unload Me
    frmMain.SuperMap.Action = scaNull
End Sub

Private Sub btnOK_Click()
    Dim objRegion As soGeoRegion                    '裁剪区域
    Dim objDsDes As soDataSource                  '目标数据源
    Dim objDtSrc As soDataset                     '源数据集(被裁剪的数据集)
    Dim objDtDes As soDataset                  '目标数据集
    Dim objLayer As soLayer
    Dim objOverlayAnalyst As New soOverlayAnalyst   '进行叠加分析的对象，一定要有new关键字
    Dim bResult As Boolean
    Dim strName As String
    Dim objGeometry As soGeometry
    Dim objGeoCircle As soGeoCircle
    Dim objGeorect As soGeoRect
    
    '取得用户在地图上画的裁剪对象
    Set objGeometry = frmMain.SuperMap.TrackedGeometry
    If objGeometry.Type = scgCircle Then
        Set objGeoCircle = objGeometry
        Set objRegion = objGeoCircle.ConvertToRegion(100)
    Else
        If objGeometry.Type = SuperMapLib.seGeometryType.scgRect Then
            Set objGeorect = objGeometry
            Set objRegion = objGeorect.ConvertToRegion()
        End If
        If objGeometry.Type = SuperMapLib.seGeometryType.scgRegion Then
            Set objRegion = objGeometry
         End If
    End If
    
    '取得目标数据源
    Set objDsDes = frmMain.SuperWorkspace.Datasources.Item(cmbDSName.Text)
    If objDsDes Is Nothing Then
        MsgBox "未能正确获取目标数据源", vbInformation
        Exit Sub
    Else        '取得源数据集（被裁减图层的数据集）：先取得数据集名称，再获得数据集
        Set objLayer = frmMain.SuperMap.Layers.Item(lblSourceLayerName.Caption)
        If objLayer Is Nothing Then
            MsgBox "获得被裁剪图层出错", vbInformation
            Exit Sub
        End If
        Set objDtSrc = objLayer.Dataset
        If objDtSrc Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
        End If
        
        '目标数据集
        If chkNewDtName.Value = 1 Then   '用户使用新数据集
            strName = txtNewDtName.Text
            If objDsDes.IsAvailableDatasetName(strName) Then      '合法数据集名
            '创建新的数据集
            Set objDtDes = objDsDes.CreateDataset(strName, objDtSrc.Type, 0)
                If objDtDes Is Nothing Then                '创建失败则提示并退出本过程
                    MsgBox objError.LastErrorMsg, vbInformation
                    Exit Sub
                End If
            Else
                MsgBox "新数据集名非法", vbInformation
                Exit Sub
            End If
        Else        '用户不使用新数据集
            Set objDtDes = objDsDes.Datasets.Item(cmbDtName.Text)
            If objDtDes Is Nothing Then
                MsgBox "未能正确获取目标数据集", vbInformation
                Exit Sub
            End If
        End If
        
        If optIn.Value = True Then                '裁剪区域内的对象(裁剪方法)
            bResult = objOverlayAnalyst.Clip(objDtSrc, objRegion, objDtDes)
        ElseIf optOut.Value = True Then           '裁剪区域外的对象(擦除方法)
            bResult = objOverlayAnalyst.Erase(objDtSrc, objRegion, objDtDes)
        End If
        
        If bResult = False Then
            MsgBox "裁剪失败！", vbInformation
            If chkNewDtName.Value = 1 Then
                Set objDtSrc = Nothing
                objDsDes.DeleteDataset strName       '失败后还要删除刚才创建的数据集
            End If
        Else
            MsgBox "裁剪成功！", vbInformation
            frmMain.SuperMap.Layers.AddDataset objDtDes, True  '成功后把它加入到地图窗口中
            frmMain.SuperMap.Refresh
        End If
    End If
    
    Set objOverlayAnalyst = Nothing
    btnCancel_Click
End Sub

Private Sub chkNewDtName_Click()
    If chkNewDtName.Value = 1 Then
        txtNewDtName.Enabled = True
        txtNewDtName.BackColor = &H80000005
        cmbDtName.Enabled = False
        cmbDtName.BackColor = &H80000004
    Else
        txtNewDtName.Enabled = False
        txtNewDtName.BackColor = &H80000004
        cmbDtName.Enabled = True
        cmbDtName.BackColor = &H80000005
    End If
End Sub

Private Sub cmbDsName_Click()
    '本过程保证：当用户改变目标数据源时，在目标数据集下拉列表框中只列出与源数据集同类型的数据集
    Dim lSourceDtType As Long                 '源数据集的类型
    Dim objDestDt As soDataset                '与源数据集同类型的目标数据集
    Dim objDatasets As soDatasets             '目标数据源中的数据集集合
    Dim objLayer As soLayer
    Dim objDs As soDataSource
    
    '取得源数据集的类型
    Set objLayer = frmMain.SuperMap.Layers.Item(lblSourceLayerName.Caption)
    lSourceDtType = objLayer.Dataset.Type
    
    cmbDtName.Clear
    '取得目标数据源中的数据集集合
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(cmbDSName.Text)
    If objDs Is Nothing Then
        MsgBox "未能正确获得目标数据源", vbInformation
        Exit Sub
    End If
    Set objDatasets = objDs.Datasets
    
    '找出与源数据集同类型的数据集，加入到下拉列表框中
    For Each objDestDt In objDatasets
        If objDestDt.Type = lSourceDtType Then
            cmbDtName.AddItem objDestDt.Name
        End If
    Next
    
    If cmbDtName.ListCount > 0 Then
        cmbDtName.ListIndex = -1
    Else
        chkNewDtName.Value = 1
    End If
End Sub

Private Sub Form_Load()
    Dim objLayer As soLayer
    Dim objDs As soDataSource
    
    Set objLayer = frmMain.SuperMap.Layers("World@World")
    If Not (objLayer Is Nothing) Then lblSourceLayerName.Caption = objLayer.Name
    
    '添加保存到数据源列表
    cmbDSName.Clear
    For Each objDs In frmMain.SuperWorkspace.Datasources
        cmbDSName.AddItem objDs.Alias
    Next
    cmbDSName.ListIndex = -1
End Sub

Private Sub txtNewDtName_Change()
    txtNewDtName.Text = Trim$(txtNewDtName.Text)
End Sub