frmoverlay.frm

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

      Y1              =   2730
      Y2              =   2730
   End
   Begin VB.Line Line1 
      BorderColor     =   &H80000005&
      Index           =   0
      X1              =   -15
      X2              =   5820
      Y1              =   2745
      Y2              =   2745
   End
End
Attribute VB_Name = "frmOverlay"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim objErr As New soError            '定义一个叠加分析错误变量

Private Sub btnCancel_Click()
      Unload Me
End Sub

Private Sub btnOK_Click()
      Dim objDSa As soDataSource     '定义叠加分析的第一数据源变量
      Dim objDSb As soDataSource     '定义叠加分析的第二数据源变量
      Dim objDSc As soDataSource     '定义保存叠加分析结果数据集的数据源变量
      Dim objDtA As soDataset        '定义叠加分析的第一数据集
      Dim objDtB As soDataset        '定义叠加分析的第二数据集
      Dim objDtC As soDataset        '定义保存叠加分析结果数据集变量
      Dim objOverlayAnalyst As New soOverlayAnalyst  '定义一个叠加分析的对象变量
      Dim nDtCType As Long           '定义叠加分析结果数据集类型变量
      Dim bResult As Boolean         '定义叠加分析结果成功与否变量
      Dim iOption As Integer         '定义数据集建立参数变量
      Dim bJoinAttrib As Boolean     '定义叠加分析是否进行属性和并变量

      objOverlayAnalyst.ShowProgress = False
      If Trim$(cmbDtNameA.Text) = "" Then
            MsgBox "请选择源数据集！", vbInformation
            cmbDtNameA.SetFocus
            Exit Sub
      End If
      If Trim$(cmbDtNameB.Text) = "" Then
            MsgBox "请选择叠加数据集！", vbInformation
            cmbDtNameB.SetFocus
            Exit Sub
      End If
      '处理第一、第二数据源、数据集
      Set objDSa = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsNameA.Text)
      Set objDSb = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsNameB.Text)
      If (objDSa Is Nothing) Then
            If objDSb Is Nothing Then
                  MsgBox objErr.LastErrorMsg, vbInformation
            Else
                  MsgBox objErr.LastErrorMsg, vbInformation
            End If
      Else
            If objDSb Is Nothing Then
                  MsgBox objErr.LastErrorMsg, vbInformation
            End If
      End If
      Set objDtA = objDSa.Datasets.Item(cmbDtNameA.Text)
      Set objDtB = objDSb.Datasets.Item(cmbDtNameB.Text)
      If objDtA Is Nothing Then
            If objDtB Is Nothing Then
                  MsgBox objErr.LastErrorMsg, vbInformation
            Else
                  MsgBox objErr.LastErrorMsg, vbInformation
            End If
            Exit Sub
      Else
            If objDtB Is Nothing Then
                  MsgBox objErr.LastErrorMsg, vbInformation
                  Exit Sub
            End If
      End If
      nDtCType = objDtA.Type
      '处理结果数据源、数据集
      Set objDSc = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsNameC.Text)
      If objDSc Is Nothing Then
            MsgBox objErr.LastErrorMsg, vbInformation
            Exit Sub
      End If
      If objDSc.IsAvailableDatasetName(Trim$(txtDtNameC.Text)) = False Then
            Set objDSc = Nothing
            MsgBox "结果数据集名称非法！", vbInformation
            txtDtNameC.SetFocus
            Exit Sub
      Else
            Set objDtC = objDSc.CreateDataset(Trim$(txtDtNameC.Text), nDtCType, iOption)
            If objDtC Is Nothing Then
                  MsgBox "数据集创建失败！", vbInformation             '
                  Exit Sub
            End If
      End If
      
      bJoinAttrib = IIf(chkJoinAttribute.Value = 1, True, False)
      '进行相应的叠加分析
      If optClip.Value = True Then              '
            bResult = objOverlayAnalyst.Clip(objDtA, objDtB, objDtC)
      ElseIf optIntersect.Value = True Then           '相交
            bResult = objOverlayAnalyst.Intersect(objDtA, objDtB, objDtC, bJoinAttrib)
      ElseIf optUnion.Value = True Then               '相并
            bResult = objOverlayAnalyst.Union(objDtA, objDtB, objDtC, bJoinAttrib)
      ElseIf optIdentity.Value = True Then            '完全切割
            bResult = objOverlayAnalyst.Identity(objDtA, objDtB, objDtC, bJoinAttrib)
      ElseIf optErase.Value = True Then               '擦除
            bResult = objOverlayAnalyst.Erase(objDtA, objDtB, objDtC)
      End If
      '报告叠加分析结果
      If bResult = False Then
            MsgBox "叠加分析失败！", vbInformation
            objDSc.DeleteDataset objDtC.Name
      Else
            '添加叠加分析结果数据集到数据集浏览器
            Select Case objDtC.Type
                  Case scdPoint
                        FrmMain.TreeView1.Nodes.Add cmbDsNameC.Text, tvwChild, , Trim$(txtDtNameC.Text), 4
                  Case scdLine
                        FrmMain.TreeView1.Nodes.Add cmbDsNameC.Text, tvwChild, , Trim$(txtDtNameC.Text), 5
                  Case scdRegion
                        FrmMain.TreeView1.Nodes.Add cmbDsNameC.Text, tvwChild, , Trim$(txtDtNameC.Text), 6
                  Case scdText
                        FrmMain.TreeView1.Nodes.Add cmbDsNameC.Text, tvwChild, , Trim$(txtDtNameC.Text), 7
                  Case Else
                        FrmMain.TreeView1.Nodes.Add cmbDsNameC.Text, tvwChild, , Trim$(txtDtNameC.Text), 3
            End Select
      End If
      '释放内存
      Set objDSa = Nothing
      Set objDSb = Nothing
      Set objDSc = Nothing
      Set objDtA = Nothing
      Set objDtB = Nothing
      Set objDtC = Nothing
      Set objOverlayAnalyst = Nothing
      
      Unload Me
End Sub



Private Sub cmbDsNameA_Click()
     '选择叠加分析的第一数据源，并装载相应的数据集
      Dim objDS As soDataSource
      Dim objDt As soDataset
      
      Set objDS = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsNameA.Text)
      If objDS Is Nothing Then
            MsgBox objErr.LastErrorMsg, vbInformation
            Exit Sub
      End If
      cmbDtNameA.Clear
      For Each objDt In objDS.Datasets
            Select Case objDt.Type
                  Case scdPoint, scdLine, scdRegion, scdNetwork
                        cmbDtNameA.AddItem objDt.Name
            End Select
      Next
      
      Set objDS = Nothing
      Set objDt = Nothing
End Sub

Private Sub cmbDsNameB_Click()
      '选择叠加分析的第二数据源，并装载相应的数据集
      Dim objDS As soDataSource
      Dim objDt As soDataset
      
      Set objDS = FrmMain.SuperWorkspace1.Datasources.Item(cmbDsNameB.Text)
      If objDS Is Nothing Then
            MsgBox objErr.LastErrorMsg, vbInformation
            Exit Sub
      End If
      cmbDtNameB.Clear
      For Each objDt In objDS.Datasets
            Select Case objDt.Type
                  Case scdRegion
                        cmbDtNameB.AddItem objDt.Name
            End Select
      Next
      
      Set objDS = Nothing
      Set objDt = Nothing
End Sub



Private Sub Form_Load()
      '添加各个数据源列表
      Dim objDS As soDataSource
      
      For Each objDS In FrmMain.SuperWorkspace1.Datasources
            cmbDsNameA.AddItem objDS.Alias
            cmbDsNameB.AddItem objDS.Alias
            cmbDsNameC.AddItem objDS.Alias
      Next
      cmbDsNameA.ListIndex = 0
      cmbDsNameB.ListIndex = 0
      cmbDsNameC.ListIndex = 0
      
      Set objDS = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
      Set objErr = Nothing
End Sub

Private Sub optClip_Click()               '剪裁
      chkJoinAttribute.Enabled = False
End Sub

Private Sub optErase_Click()              '擦除
      chkJoinAttribute.Enabled = False
End Sub

Private Sub optIdentity_Click()           '切割
      chkJoinAttribute.Enabled = True
End Sub

Private Sub optIntersect_Click()          '相交
      chkJoinAttribute.Enabled = True
End Sub

Private Sub optUnion_Click()              '合并
      chkJoinAttribute.Enabled = True
End Sub

Private Sub txtDtNameC_LostFocus()
      txtDtNameC.Text = Trim$(txtDtNameC.Text)
End Sub