frmobjmanipulate.frm

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

                    Exit Sub
                End If
                Select Case objSourceGeoMetry.Type
                    Case scgLine            '线对象的相交
                        If bFirst Then
                            Set objLine = objRecordset.GetGeometry()
                            If objLine Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                            End If
                            bFirst = False
                        Else
                            Set objPoints = objLine.Intersect(objSourceGeoMetry)
                            If objPoints Is Nothing Then
                                Exit Sub
                            End If
                            objLine.RemovePartAt 1
                            objLine.AddPart objPoints
                        End If
                    Case scgRegion                '面对象的相交
                        If bFirst Then
                            Set objRegion = objRecordset.GetGeometry()
                            If objRegion Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                            End If
                            bFirst = False
                        Else
                            Set objRegion = objRegion.Intersect(objSourceGeoMetry)
                            If objRegion Is Nothing Then
                                MsgBox "所选对象没有公共部分!", vbInformation
                                Exit For
                            End If
                        End If
                End Select
                objRecordset.MoveNext
            Next
            If Not (objLine Is Nothing) Then
                objDestRecordSet.AddNew objLine
            ElseIf Not (objRegion Is Nothing) Then
                objDestRecordSet.AddNew objRegion
            End If
            Set objPoints = Nothing
            objDestRecordSet.Update
        Case 3      '异或，只做了面对象异或操作
            For i = 1 To nSelectCount
                Set objSourceGeoMetry = objRecordset.GetGeometry()
                If bFirst Then
                    Set objRegion = objSourceGeoMetry
                    bFirst = False
                Else
                    Set objRegion = objRegion.Xor(objSourceGeoMetry)
                End If
                objRecordset.MoveNext
            Next
            objDestRecordSet.AddNew objRegion
            objDestRecordSet.Update
        Case 4      '克隆
            For i = 1 To nSelectCount
                Set objSourceGeoMetry = objRecordset.GetGeometry()
                If objSourceGeoMetry Is Nothing Then
                    MsgBox "错误！", vbInformation
                    Exit Sub
                End If
                objDestRecordSet.AddNew objSourceGeoMetry
                objDestRecordSet.Update
                objRecordset.MoveNext
            Next
        Case 5      '线 -> 面
            For i = 1 To nSelectCount
                Set objLine = objRecordset.GetGeometry()
                If objLine Is Nothing Then
                    MsgBox "错误！", vbInformation
                    Exit Sub
                End If
                Set objRegion = objLine.ConvertToRegion()
                If objRegion Is Nothing Then
                    MsgBox "错误！", vbInformation
                    Exit Sub
                End If
                objDestRecordSet.AddNew objRegion
                objDestRecordSet.Update
                objRecordset.MoveNext
            Next
        Case 6      '面 -> 线
            For i = 1 To nSelectCount
                Set objRegion = objRecordset.GetGeometry()
                If objRegion Is Nothing Then
                    MsgBox "错误！", vbInformation
                    Exit Sub
                End If
                Set objLine = objRegion.ConvertToLine()
                If objLine Is Nothing Then
                    MsgBox "错误！", vbInformation
                    Exit Sub
                End If
                objDestRecordSet.AddNew objLine
                objDestRecordSet.Update
                objRecordset.MoveNext
            Next
        Case 7      '分解复杂对象
            Set objRecordset = FrmMain.SuperMap1.selection.ToRecordset(False)
            If objRecordset Is Nothing Then
                MsgBox "所选对象的有关数据被损坏，无法继续！", vbCritical
                Exit Sub
            End If
            objRecordset.MoveFirst
            Dim j As Integer
            Dim lPartCount As Long
            Select Case FrmMain.SuperMap1.selection.Dataset.Type
                Case scdRegion                                  '分解面类型复杂对象
                      Dim objRegionNew As New soGeoRegion
                      For j = 1 To nSelectCount
                            Set objSourceGeoMetry = objRecordset.GetGeometry()
                            If objSourceGeoMetry Is Nothing Then
                                  MsgBox "错误！", vbInformation
                                  Exit Sub
                            End If
                            lPartCount = objSourceGeoMetry.PartCount
                            For i = 1 To lPartCount
                                  Set objPoints = objSourceGeoMetry.GetPartAt(i)
                                  If objSourceGeoMetry Is Nothing Then
                                        MsgBox "错误！", vbInformation
                                        Exit Sub
                                  End If
                                  objRegionNew.AddPart objPoints
                                  objDestRecordSet.AddNew objRegionNew
                                  objDestRecordSet.Update
                                  objRegionNew.RemovePartAt 1
                            Next i
                            objRecordset.MoveNext
                      Next j
                      Set objRegionNew = Nothing
                Case scdLine                                    '分解线类型复杂对象
                    Dim objLineNew As New soGeoLine
                    For j = 1 To nSelectCount
                          Set objSourceGeoMetry = objRecordset.GetGeometry()
                          If objSourceGeoMetry Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                          End If
                          lPartCount = objSourceGeoMetry.PartCount
                          For i = 1 To lPartCount
                                Set objPoints = objSourceGeoMetry.GetPartAt(i)
                                If objPoints Is Nothing Then
                                      MsgBox "错误！", vbInformation
                                      Exit Sub
                                End If
                                objLineNew.AddPart objPoints
                                objDestRecordSet.AddNew objLineNew
                                objDestRecordSet.Update
                                objLineNew.RemovePartAt 1
                          Next i
                          objRecordset.MoveNext
                    Next j
                    Set objLineNew = Nothing
                Case scdText                                    '分解注记类型复杂对象
                    Dim objTextPart As soTextPart
                    Dim objTextNew As New soGeoText
                    For j = 1 To nSelectCount
                          Set objText = objRecordset.GetGeometry()
                          If objText Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                          End If
                          Set objTextNew.TextStyle = objText.TextStyle
                          If objTextNew.TextStyle Is Nothing Then
                                MsgBox "错误！", vbInformation
                                Exit Sub
                          End If
                          objTextNew.TextStyle.SubCount = 0
                          objTextNew.FontName = objText.FontName
                          lPartCount = objText.PartCount
                          For i = 1 To lPartCount
                                Set objTextPart = objText.GetPartAt(i)
                                If objTextPart Is Nothing Then
                                      MsgBox "错误！", vbInformation
                                      Exit Sub
                                End If
                                objTextNew.AddPart objTextPart
                                objDestRecordSet.AddNew objTextNew
                                objDestRecordSet.Update
                                objTextNew.RemovePartAt 1
                          Next i
                          objRecordset.MoveNext
                    Next j
                    Set objTextNew = Nothing
                    Set objTextPart = Nothing
                Case Else
                End Select
            Case 8                  '线对象连接
                For i = 1 To nSelectCount
                      Set objSourceGeoMetry = objRecordset.GetGeometry()
                      If objSourceGeoMetry Is Nothing Then
                            MsgBox "错误！", vbInformation
                            Exit Sub
                      Else
                            If bFirst = True Then
                                  Set objLine = objSourceGeoMetry
                                  If objLine Is Nothing Then
                                        MsgBox "错误！", vbInformation
                                        Exit Sub
                                  End If
                                  bFirst = False
                            Else
                                   objLine.Joint objSourceGeoMetry
                            End If
                      End If
                      objRecordset.MoveNext
                Next
                If Not (objLine Is Nothing) Then
                      objDestRecordSet.AddNew objLine
                End If
                objDestRecordSet.Update
    End Select
    If chkDelSourceObj.Value = 1 Then
        objRecordset.MoveFirst
        For i = 1 To objRecordset.RecordCount
            objRecordset.Delete
            objRecordset.MoveNext
        Next
    End If
    
    Set objLine = Nothing
    Set objPoint = Nothing
    Set objRecordset = Nothing
    Set objDestRecordSet = Nothing
    Set objRegion = Nothing
    Set objText = Nothing
    Set objSourceGeoMetry = Nothing
    Set objDestDtVector = Nothing
    
    FrmMain.SuperMap1.Refresh
    Unload Me
End Sub

Private Sub btnCancel_Click()
    Unload Me
End Sub

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

'================================================================================
'cmbDtName是存放生成结果的数据集列表，类型转换：线-> 面时，cmbDtName中是面数据集，
'面->线转换时，cmbDtName中是线数据集；除此以外，cmbDtName中为与所选对象同类型的数据集
'================================================================================
Private Sub cmbDsName_Click()
    Dim i As Integer
    Dim objDS As soDataSource
    Dim objDt As soDataset
    
    Set objDS = FrmMain.SuperWorkspace1.Datasources(cmbDsName.Text)
    If objDS Is Nothing Then
        MsgBox "数据源" & cmbDsName.Text & "内部错误，无法继续!", vbInformation
        Exit Sub
    End If
    cmbDtName.Clear
    For Each objDt In objDS.Datasets
        If Not (objDt Is Nothing) Then
            Select Case Me.iManipulate
                Case 5                  ' "类型转换：线 -> 面"
                    If objDt.Type = scdRegion Then
                        cmbDtName.AddItem objDt.Name
                    End If
                Case 6                  ' "类型转换：面 -> 线"
                    If objDt.Type = scdLine Then
                        cmbDtName.AddItem objDt.Name
                    End If
                Case Else
                    If objDt.Type = FrmMain.SuperMap1.selection.Dataset.Type Then
                        cmbDtName.AddItem objDt.Name
                    End If
            End Select
            '对象操作的结果都可以放到CAD图层中去。
            If objDt.Type = scdCAD Then cmbDtName.AddItem objDt.Name
        End If
    Next
    If cmbDtName.ListCount > 0 Then cmbDtName.ListIndex = 0
    
    Set objDS = Nothing
    Set objDt = Nothing
End Sub

Private Sub Form_Activate()
    Dim objDS As soDataSource
    Dim objDt As soDataset

    For Each objDS In FrmMain.SuperWorkspace1.Datasources
        cmbDsName.AddItem objDS.Alias
    Next

    Set objDt = FrmMain.SuperMap1.selection.Dataset
    cmbDsName.Text = objDt.DataSourceAlias
    
    Set objDS = Nothing
    Set objDt = Nothing
End Sub