frmobjedit.frm

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

            iDtType = frmMain.SuperMap.selection.Dataset.Type
            Set objRecordset = frmMain.SuperMap.selection.ToRecordset(False)
            If objRecordset Is Nothing Then
                  MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            End If
            Select Case iDtType
                  Case scdRegion         '获取面状几何对象
                        Set objRegion = objRecordset.GetGeometry()
                        If objRegion Is Nothing Then
                              MsgBox objError.LastErrorMsg, vbInformation
                              Exit Sub
                        End If
                        nID = objRecordset.GetID
                  Case scdLine           '获取线状几何对象
                        Set objLine = objRecordset.GetGeometry()
                        If objLine Is Nothing Then
                              MsgBox objError.LastErrorMsg, vbInformation
                              Exit Sub
                        End If
                        nID = objRecordset.GetID
                  Case scdPoint          '获取点状几何对象
                        Set objPoint = objRecordset.GetGeometry()
                        If objPoint Is Nothing Then
                              MsgBox objError.LastErrorMsg, vbInformation
                              Exit Sub
                        End If
                        nID = objRecordset.GetID
            End Select
            For i = 1 To lsvPartXY.ListItems.Count
                objPoints.Add2 lsvPartXY.ListItems.Item(i).SubItems(1), lsvPartXY.ListItems.Item(i).SubItems(2)
            Next
            Dim bResult As Boolean
            Select Case iDtType
                  Case scdRegion         '处理面状对象的精确配准
                        bResult = objRegion.SetPartAt(CLng(Val(cmbCurrentPart.Text)), objPoints)
                        If bResult = True Then
                              If objRecordset.SeekID(nID) = True Then
                                    objRecordset.Edit
                                    bResult = objRecordset.SetGeometry(objRegion)
                              End If
                        End If
                  Case scdLine           '处理线状对象的精确配准
                        bResult = objLine.SetPartAt(cmbCurrentPart.Text, objPoints)
                        If bResult = True Then
                              If objRecordset.SeekID(nID) = True Then
                                    objRecordset.Edit
                                    bResult = objRecordset.SetGeometry(objLine)
                              End If
                        End If
                 Case scdPoint           '处理点状对象的精确配准
                        objPoint.x = lsvPartXY.ListItems(1).SubItems(1)
                        objPoint.y = lsvPartXY.ListItems(1).SubItems(2)
                        If objRecordset.SeekID(nID) = True Then
                              objRecordset.Edit
                              bResult = objRecordset.SetGeometry(objPoint)
                        End If
            End Select
            If bResult = True Then
                  objRecordset.Update       '更新数据记录
                  frmMain.SuperMap.Refresh  '刷新
            Else
                  MsgBox objError.LastErrorMsg, vbInformation
            End If
              
            '释放内存
            Set objRecordset = Nothing
            Set objRegion = Nothing
            Set objLine = Nothing
            Set objPoint = Nothing
            Erase sUpdataNodeIndex                  ' 重新初始化大小固定的数组sUpdataNodeIndex的元素，以及释放动态数组的存储空间
      End If
      frmMain.SuperMap.TrackingLayer.ClearEvents    '清除所有实例
      bModify = False
      Set objPoints = Nothing
End Sub

Private Sub btnCancel_Click()
      Unload Me
      frmMain.SuperMap.TrackingLayer.ClearEvents
      frmMain.SuperMap.selection.RemoveAll
End Sub

Private Sub btnClose_Click()
      btnApply_Click
      btnCancel_Click
End Sub

Private Sub btnDel_Click()
      '删除顶点
      If lsvPartXY.SelectedItem Is Nothing Then
            Exit Sub
      Else
            lsvPartXY.ListItems.Remove (lsvPartXY.SelectedItem.Index)
      End If
End Sub

Private Sub btnUpdate_Click()
      '更新列表
      If lsvPartXY.SelectedItem Is Nothing Then Exit Sub
      ReDim Preserve sUpdataNodeIndex(1 To 1) As String
      sUpdataNodeIndex(UBound(sUpdataNodeIndex, 1)) = lsvPartXY.SelectedItem.Index
      bModify = True
      lsvPartXY.SelectedItem.SubItems(1) = Val(txtX.Text)
      lsvPartXY.SelectedItem.SubItems(2) = Val(txtY.Text)
End Sub

'==========================================================================================================
'    线和面状对象有一个或多个点集合，改变此项，可改变相对应的点集合，从而修改不同不分的点
'==========================================================================================================

Private Sub cmbCurrentPart_Click()
      '判断是否已经修改，如果修改则保存修改
      If bModify Then
            If MsgBox("当前子对象已经修改，保存修改吗？", vbYesNo + vbQuestion) = vbYes Then
                  btnApply_Click
            End If
            Erase sUpdataNodeIndex
            bModify = False
      End If
      
      Dim objRecordset As soRecordset           '定义记录变量，接受选中的记录
      Dim objRegion As soGeoRegion              '定义面状几何对象，接受面状数据集的几何对象
      Dim objLine As soGeoLine                  '定义线状几何对象，接受线状数据集的几何对象
      Dim objPoint As soGeoPoint                '定义点状几何对象，接受点状数据集的几何对象
      Dim objPoints As soPoints                 '定义点集合对象，接受点集合型数据集的几何对象
      Dim i As Integer                          '
      
      Set objRecordset = frmMain.SuperMap.selection.ToRecordset(False)      '获取被选中对象的记录
      If objRecordset Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      End If
      If frmMain.SuperMap.selection.Dataset.Type = scdRegion Then
            Set objRegion = objRecordset.GetGeometry()                      '获取面状几何对象
            If objRegion Is Nothing Then
                 MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            End If
            Set objPoints = objRegion.GetPartAt(Val(cmbCurrentPart.Text))   '获取面状几何对象的某一部分的点集合
            If objPoints Is Nothing Then
                 MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            Else
                  '更新节点坐标列表框
                  iNodeCount = objPoints.Count
                  lsvPartXY.ListItems.Clear
                  For i = 1 To iNodeCount
                        lsvPartXY.ListItems.Add , , i
                        lsvPartXY.ListItems(i).SubItems(1) = objPoints.Item(i).x
                        lsvPartXY.ListItems(i).SubItems(2) = objPoints.Item(i).y
                  Next i
            End If
      ElseIf frmMain.SuperMap.selection.Dataset.Type = scdLine Then
            Set objLine = objRecordset.GetGeometry()                        '获取线状几何对象
            If objLine Is Nothing Then
                 MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            End If
            Set objPoints = objLine.GetPartAt(Val(cmbCurrentPart.Text))     '获取线状几何对象的某一部分的点集合
            If objPoints Is Nothing Then
                 MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            Else
                  '更新节点坐标列表框
                  iNodeCount = objPoints.Count
                  lsvPartXY.ListItems.Clear
                  For i = 1 To iNodeCount
                        lsvPartXY.ListItems.Add , , i
                        lsvPartXY.ListItems(i).SubItems(1) = objPoints.Item(i).x
                        lsvPartXY.ListItems(i).SubItems(2) = objPoints.Item(i).y
                  Next i
            End If
      ElseIf frmMain.SuperMap.selection.Dataset.Type = scdPoint Then
            Set objPoint = objRecordset.GetGeometry()                        '获取点状几何对象
            If objPoint Is Nothing Then
                 MsgBox objError.LastErrorMsg, vbInformation
                  Exit Sub
            End If
            If Not (objPoint Is Nothing) Then
               '更新节点坐标列表框
                iNodeCount = objPoint.PartCount
                lsvPartXY.ListItems.Clear
                lsvPartXY.ListItems.Add , , 1
                lsvPartXY.ListItems(1).SubItems(1) = objPoint.x
                lsvPartXY.ListItems(1).SubItems(2) = objPoint.y
            End If
      End If
      '释放内存
      Set objRecordset = Nothing
      Set objRegion = Nothing
      Set objLine = Nothing
      Set objPoints = Nothing
      Set objPoint = Nothing
End Sub

Private Sub Form_Load()
      Dim i As Integer
      
      frmMain.SuperMap.Action = scaSelect
      bModify = False
End Sub

Private Sub lsvPartXY_ItemClick(ByVal Item As MSComctlLib.ListItem)
      Dim objPoint As New soGeoPoint            '定义点实例几何对象变量
      Dim objStyle As New soStyle               '定义点实例风格变量
      
      '通过点坐标的选择来改变要修改的点
      If lsvPartXY.SelectedItem Is Nothing Then Exit Sub
      If lsvPartXY.SelectedItem.SubItems(1) = "" Then Exit Sub
      If lsvPartXY.SelectedItem.SubItems(2) = "" Then Exit Sub
      txtX.Text = lsvPartXY.SelectedItem.SubItems(1)
      txtY.Text = lsvPartXY.SelectedItem.SubItems(2)
      
      
      '在地图上用点实例来标注当前点的具体位置
      objPoint.x = lsvPartXY.SelectedItem.SubItems(1)
      objPoint.y = lsvPartXY.SelectedItem.SubItems(2)
      objStyle.PenColor = vbRed
      objStyle.SymbolSize = 80
      objStyle.SymbolStyle = 1
      frmMain.SuperMap.TrackingLayer.ClearEvents
      frmMain.SuperMap.TrackingLayer.AddEvent objPoint, objStyle, ""
      frmMain.SuperMap.Refresh
      
      '释放内存
      Set objPoint = Nothing
      Set objStyle = Nothing
End Sub

Private Sub txtX_KeyPress(KeyAscii As Integer)

      If (KeyAscii > Asc("9")) Or (KeyAscii < Asc("0")) Then
            If (KeyAscii <> vbKeyBack) And (KeyAscii <> Asc(".")) And (KeyAscii <> Asc("-")) Then
                  KeyAscii = 0
                  Beep
            End If
      End If
End Sub

Private Sub txtY_KeyPress(KeyAscii As Integer)
      If KeyAscii > Asc("9") Or KeyAscii < Asc("0") Then
            If (KeyAscii <> vbKeyBack) And (KeyAscii <> Asc(".")) And (KeyAscii <> Asc("-")) Then
                  KeyAscii = 0
                  Beep
            End If
      End If
End Sub