frmmain.frm

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

      Dim i As Integer
           
      If tvwData.SelectedItem.Index = 1 Then
            Exit Sub
      Else
            strDtName = tvwData.SelectedItem.Text
      End If
      
      Set objDS = SuperWorkspace.Datasources(1)
      If objDS Is Nothing Then Exit Sub
      Set objDt = objDS.Datasets(strDtName)
      If (objDt Is Nothing) Then Exit Sub
      
      i = 1
      strDtNewName = strDtName & "复件" & i
      '循环对复制数据集进行自动取名
      Do While Not objDS.IsAvailableDatasetName(strDtNewName)
            strDtNewName = strDtName & "复件" & i
            i = i + 1
      Loop
      
      Set objDtNew = objDS.CopyDataset(objDt, strDtNewName, True)
      If Not (objDtNew Is Nothing) Then
            MsgBox "数据集复制成功！", vbInformation
            '将复制结果添加到treeview
            Select Case objDtNew.Type
                  Case scdPoint
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 10
                  Case scdLine
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 12
                  Case scdRegion
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 4
                  Case scdText
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 11
                  Case scdCAD
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 13
                  Case scdNetwork
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 3
                  Case scdTIN
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 6
                  Case scdECW
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 16
                  Case scdMrSID
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 17
                  Case Else
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , strDtNewName, 7
            End Select
      End If
      
      Set objDS = Nothing
      Set objDt = Nothing
      Set objDtNew = Nothing
End Sub

Private Sub btnDelDt_Click()
      '永久删除数据集
      Dim objDS As soDataSource
      Dim strDtName As String
      
      If tvwData.SelectedItem.Index = 1 Then
            Exit Sub
      Else
            strDtName = tvwData.SelectedItem.Text
      End If
      '提出警告信息
      If MsgBox("这将删除实际数据，而且不能恢复，继续吗？", vbQuestion + vbYesNo) = vbNo Then Exit Sub
      
      If SuperMap.Layers.Count > 0 Then
            If InStr(SuperMap.Layers(1).Name, strDtName) <> 0 Then
                  If MsgBox("数据集正被显示，删除吗！", vbQuestion + vbYesNo) = vbNo Then
                        Exit Sub
                  Else
                        SuperMap.Layers.RemoveAll
                        SuperMap.Action = scaNull
                        SuperMap.Refresh
                  End If
            End If
      End If
      Set objDS = SuperWorkspace.Datasources(1)
      If objDS Is Nothing Then Exit Sub
      
      '判断删除结果是否为真
      If objDS.DeleteDataset(strDtName) = True Then
            tvwData.Nodes.Remove tvwData.SelectedItem.Index
      Else
            MsgBox "删除失败！", vbInformation       '报告删除失败消息
      End If
      
      Set objDS = Nothing
End Sub

Private Sub btnDelTopoErr_Click()
      '删除拓扑错误几何对象
      Dim objDtVector As soDatasetVector
      Dim objRecordset As soRecordset
      Dim strQueryFilter As String
      '提取矢量拓扑数据集
      Set objDtVector = SuperWorkspace.Datasources(1).Datasets(tvwData.SelectedItem.Text)
      If Not (objDtVector Is Nothing) Then
            '获取拓扑错误记录
            Set objRecordset = objDtVector.Query("smtopoerror <>0 ", True)
            If Not (objRecordset Is Nothing) Then
                  objRecordset.MoveFirst
                  '删除全部拓扑错误对象
                  Do Until objRecordset.IsEOF
                        objRecordset.Delete
                        objRecordset.Update '更新数据集
                        
                        objRecordset.MoveNext
                  Loop
            End If
            SuperMap.Refresh
      End If
      
      Set objDtVector = Nothing
      Set objRecordset = Nothing
End Sub

Private Sub btnDisplyDt_Click()
      '显示选择的数据集
      Dim objDS As soDataSource
      Dim objDt As soDataset
      
      If tvwData.SelectedItem.Index = 1 Then Exit Sub
      '获取数据源
      Set objDS = SuperWorkspace.Datasources(1)
      If objDS Is Nothing Then Exit Sub
      '获取要显示的数据集
      Set objDt = objDS.Datasets(tvwData.SelectedItem.Text)
      If objDt Is Nothing Then
            MsgBox "错误！", vbInformation
      Else
            '重新显示SuperMap1中的数据集对象
            SuperMap.Layers.RemoveAll
            SuperMap.Layers.AddDataset objDt, True
            SuperMap.ViewEntire
            SuperMap.Refresh
      End If
      
      Set objDt = Nothing
      Set objDt = Nothing
End Sub

Private Sub btnExit_Click()
      Unload Me
End Sub

Private Sub btnPan_Click()
      SuperMap.Action = scaPan       '漫游状态
End Sub

Private Sub btnSelect_Click()
      SuperMap.Action = scaSelect    '选择状态
End Sub

Private Sub btnTopoErr_Click()
      '显示拓扑错误信息
      Dim objDtVector As soDatasetVector
      Dim objRecordset As soRecordset
      Dim strQueryFilter As String
      
      SuperMap.Layers.RemoveAll
      Set objDtVector = SuperWorkspace.Datasources(1).Datasets(tvwData.SelectedItem.Text)
      If Not (objDtVector Is Nothing) Then
            SuperMap.Layers.AddDataset objDtVector, True
            '提取错误集合对象
            Set objRecordset = objDtVector.Query("smtopoerror <>0 ", True)
            If Not (objRecordset Is Nothing) Then
                  SuperMap.selection.FromRecordset objRecordset
            End If
            SuperMap.Refresh
      End If
      
      Set objDtVector = Nothing
      Set objRecordset = Nothing
End Sub

Private Sub btnTopu_Click()
      If (tvwData.SelectedItem.Image = 3) Or (tvwData.SelectedItem.Image = 12) Then
            If MsgBox("进行拓扑处理将会改变被处理的数据集，建议先单击【备份数据集按钮】将该数据集进行备份！要进行备份吗？", vbYesNo) = vbYes Then
                  btnCopyDt_Click '先备份数据集
            Else
                  frmTopo.Show vbModal, Me   '拓扑处理，显示拓扑对话框
            End If
      End If
End Sub

Private Sub btnViewEntire_Click()
      SuperMap.ViewEntire              '全幅显示
      SuperMap.Refresh
End Sub


Private Sub btnZoomOUt_Click()
      SuperMap.Action = scaZoomOut
End Sub

Private Sub btnZoonIn_Click()
      SuperMap.Action = scaZoomIn
End Sub

Private Sub Form_Load()
      SuperMap.Connect SuperWorkspace.Handle
      
      Dim objDS As soDataSource
      Dim i As Integer
      
      Set objDS = SuperWorkspace.OpenDataSource(App.Path & "\..\data\world\world.sdb", "SampleData", sceSDBPlus, False)
      If objDS Is Nothing Then
            MsgBox "打开数据失败！", vbCritical
            End
      End If
      tvwData.Nodes.Add , tvwFirst, objDS.Alias, objDS.Alias, 1, 2
      '将数据集名加入TreeView控件，并根据数据集类型改变数据集图标
      For i = 1 To objDS.Datasets.Count
            Select Case objDS.Datasets(i).Type
                  Case scdPoint                                 'point dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 10
                  Case scdLine                                  'line dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 12
                  Case scdRegion                                'region dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 4
                  Case scdText                                  'text dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 11
                  Case scdCAD                                   'CAD dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 13
                  Case scdNetwork                               'Network dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 3
                  Case scdTIN                                   'TIN dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 6
                  Case scdECW                                   'ECW  dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 16
                  Case scdMrSID                                 'MrSID dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 17
                  Case Else                                     'other dataset
                        tvwData.Nodes.Add objDS.Alias, tvwChild, , objDS.Datasets(i).Name, 7
            End Select
      Next
      tvwData.Nodes(1).Expanded = True       'Expand the first node
      
      Set objDS = Nothing                    'clear memory
End Sub

Private Sub Form_Resize()
      SuperMap.Width = Me.ScaleWidth - SuperMap.Left - 20
      SuperMap.Height = Me.ScaleHeight - SuperMap.Top - 20
End Sub

Private Sub Form_Unload(Cancel As Integer)
      SuperMap.Close
      SuperMap.Disconnect
      SuperWorkspace.Close
End Sub

Private Sub tvwData_DblClick()
      Call btnDisplyDt_Click
End Sub

Private Sub tvwData_NodeClick(ByVal Node As MSComctlLib.Node)
      If Node.Index = 1 Then
            btnDisplyDt.Enabled = False
            btnDelDt.Enabled = False
      Else
            btnDisplyDt.Enabled = True
            btnDelDt.Enabled = True
      End If
      If (Node.Image = 3) Or (Node.Image = 12) Then
            btnTopu.Enabled = True
            btnTopoErr.Enabled = True
            btnDelTopoErr.Enabled = True
            btnCopyDt.Enabled = True
      Else
            btnTopu.Enabled = False
            btnTopoErr.Enabled = False
            btnDelTopoErr.Enabled = False
            btnCopyDt.Enabled = False
      End If

End Sub