frmtopo.frm

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

            Height          =   225
            Left            =   390
            TabIndex        =   31
            Tag             =   "3266"
            Top             =   1545
            Width           =   1620
         End
         Begin VB.CheckBox chkMPN 
            Caption         =   "合并假结点"
            Height          =   240
            Left            =   3060
            TabIndex        =   30
            Tag             =   "3267"
            Top             =   330
            Value           =   1  'Checked
            Width           =   1620
         End
         Begin VB.CheckBox chkCOD 
            Caption         =   "去除短悬线"
            Height          =   255
            Left            =   390
            TabIndex        =   29
            Tag             =   "3268"
            Top             =   1140
            Value           =   1  'Checked
            Width           =   1620
         End
         Begin VB.CheckBox chkEDL 
            Caption         =   "延长长悬线"
            Height          =   240
            Left            =   3060
            TabIndex        =   28
            Tag             =   "3269"
            Top             =   1095
            Width           =   1620
         End
      End
   End
   Begin VB.CommandButton btnCanel 
      Cancel          =   -1  'True
      Caption         =   "放  弃[&C]"
      Height          =   375
      Left            =   4200
      TabIndex        =   8
      Tag             =   "3058"
      Top             =   4350
      Width           =   1170
   End
   Begin VB.CommandButton btnOK 
      Caption         =   "确  定[&O]"
      Default         =   -1  'True
      Height          =   375
      Left            =   1380
      TabIndex        =   0
      Tag             =   "3057"
      Top             =   4350
      Width           =   1170
   End
End
Attribute VB_Name = "frmTopo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'====================================================================================================
'
' 说 明 :此模块是用来对图层进行拓扑分析时，设置各种参数的，可以通过操作者对参数的选择，进行相应的拓扑分析，
'        还可以决定是否进行生成网络数据集和拓扑多边形，并显示拓扑生成错误信息
'
'====================================================================================================

Option Explicit
Dim objError As soError

Private Sub btnCanel_Click()
      Unload Me
End Sub

Private Sub btnClear_Click()
      Dim objDS As soDataSource
      Dim objDtVector As soDatasetVector
      Dim strName As String
      
      strName = frmMain.tvwData.SelectedItem.Parent.Text
      Set objDS = frmMain.SuperWorkspace.Datasources.Item(strName)
      If objDS Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      End If
      strName = frmMain.tvwData.SelectedItem.Text
      Set objDtVector = objDS.Datasets.Item(strName)
      If objDtVector Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Set objDS = Nothing
            Exit Sub
      End If
      objDtVector.EmptyTolerance
      txtFuzzy.Text = "0"
      txtDangle.Text = "0"
      txtNodesnap.Text = "0"
      txtSmallplygon.Text = "0"
      txtGrain.Text = "0"

End Sub

Private Sub btnDefault_Click()
      '设置系统的默认值
      Dim DtVector As soDatasetVector
      Dim DS As soDataSource
      Dim strName As String
      
      strName = frmMain.tvwData.SelectedItem.Parent.Text
      Set DS = frmMain.SuperWorkspace.Datasources.Item(strName)
      If DS Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      End If
      strName = frmMain.tvwData.SelectedItem.Text
      Set DtVector = DS.Datasets.Item(strName)
      If DtVector Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      End If
     
      DtVector.SetToleranceToDefault
      
      Set DS = Nothing
      Set DtVector = Nothing
End Sub

'=================================================================
'进行拓扑处理.首先处理错误选项,再创建拓扑多边形,做网络拓扑和生成错误信息.
'=================================================================
Private Sub btnOK_Click()
      Dim bTopuPolygon As Boolean
      Dim bNetTopu As Boolean
      Dim bResult As Boolean
      Dim strDsName As String
      Dim strNetName As String
      Dim strPolygonName As String

      Dim DS As soDataSource
      Dim Dt As soDataset
      Dim DtVector  As soDatasetVector
      
      frmMain.SuperMap.Layers.RemoveAll
      frmMain.SuperMap.Action = scaNull
      frmMain.SuperMap.Refresh
      DoEvents
      
      bTopuPolygon = IIf(chkTopuPolygon.Value = 1, True, False)
      bNetTopu = IIf(chkNetTopu.Value = 1, True, False)
      
      strNetName = Trim(txtNetName.Text)
      strPolygonName = Trim(txtPolygonName.Text)
      strDsName = frmMain.tvwData.SelectedItem.Parent.Text
      Set DS = frmMain.SuperWorkspace.Datasources.Item(strDsName)
      If DS Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      Else
            '检查网络拓扑时数据集名称的合法性
            If bNetTopu Then
                  If DS.IsAvailableDatasetName(strNetName) = False Then      '网络图层名称非法
                        MsgBox " 网络数据集名称非法！  ", vbInformation
                        txtNetName.SetFocus
                        Exit Sub
                  End If
            End If
            '检查多边形拓扑时数据集名称的合法性
            If bTopuPolygon = True Then
                  If DS.IsAvailableDatasetName(strPolygonName) = False Then   '多边形图层名称非法
                        MsgBox " 多边形数据集名称非法！  ", vbInformation
                        txtPolygonName.SetFocus
                        Exit Sub
                  End If
            End If
      End If
      
      Set Dt = DS.Datasets.Item(frmMain.tvwData.SelectedItem.Text)
      If Dt Is Nothing Then
            MsgBox objError.LastErrorMsg, vbInformation
            Exit Sub
      End If
      '进行相应选项的拓扑分析
      With frmMain.SuperTopo1
          .CleanIdenticalVertices = IIf(chkCIV.Value = vbUnchecked, False, True)
          .CleanOvershootDangles = IIf(chkCOD.Value = vbUnchecked, False, True)
          .CleanRepeatedLines = IIf(chkCRL.Value = vbUnchecked, False, True)
          .ExtendDangleLines = IIf(chkEDL.Value = vbUnchecked, False, True)
          .IntersectLines = IIf(chkIL.Value = vbUnchecked, False, True)
          .MergePseudoNodes = IIf(chkMPN.Value = vbUnchecked, False, True)
          .MergeRedundantNodes = IIf(chkMRN.Value = vbUnchecked, False, True)
          .Clean Dt
      End With
      
      If chkErrInfo.Value = vbChecked Then
            frmMain.SuperTopo1.CheckErrors Dt
      End If
      
      Set DtVector = DS.Datasets.Item(frmMain.tvwData.SelectedItem.Text)
      
      DtVector.ToleranceDangle = IIf(Trim$(txtDangle.Text) = "", "0", CDbl(Val(Trim$(txtDangle.Text))))
      DtVector.ToleranceFuzzy = IIf(Trim$(txtFuzzy.Text) = "", "0", CDbl(Val(Trim$(txtFuzzy.Text))))
      DtVector.ToleranceGrain = IIf(Trim$(txtGrain.Text) = "", "0", CDbl(Val(Trim$(txtGrain.Text))))
      DtVector.ToleranceNodeSnap = IIf(Trim$(txtNodesnap.Text) = "", "0", CDbl(Val(Trim$(txtNodesnap.Text))))
      DtVector.ToleranceSmallPolygon = IIf(Trim$(txtSmallplygon.Text) = "", "0", CDbl(Val(Trim$(txtSmallplygon.Text))))
      
      If bNetTopu Then              '建立网络拓扑
            bResult = False
            bResult = frmMain.SuperTopo1.BuildNetwork(Dt, DS, strNetName)
            If bResult = True Then
                  frmMain.tvwData.Nodes.Add DS.Alias, tvwChild, , strNetName, 3
            End If
      End If
      
      If bTopuPolygon Then          '建立拓扑多边形
            bResult = False
            bResult = frmMain.SuperTopo1.BuildPolygons(Dt, DS, strPolygonName)
            If bResult Then
                  frmMain.tvwData.Nodes.Add DS.Alias, tvwChild, , strPolygonName, 4
            End If
      End If
      
        Set DS = Nothing
        Set Dt = Nothing
        Unload Me
End Sub

Private Sub btnSelectAll_Click()
      '全部选中，进行以上全部选项的拓扑分析
      chkIL.Value = vbChecked         '弧段求交
      chkCIV.Value = vbChecked        '去除冗余点
      chkMRN.Value = vbChecked        '合并邻近结点
      chkCRL.Value = vbChecked        '去除重复线
      chkMPN.Value = vbChecked        '合并假结点
      chkCOD.Value = vbChecked        '去除短悬线
      chkEDL.Value = vbChecked        '延长长悬线
End Sub

Private Sub btnUnSelectAll_Click()
      '全部取消，不进行以上选项的拓扑分析
      chkIL.Value = vbUnchecked       '弧段求交
      chkCIV.Value = vbUnchecked      '去除冗余点
      chkMRN.Value = vbUnchecked      '合并邻近结点
      chkCRL.Value = vbUnchecked      '去除重复线
      chkMPN.Value = vbUnchecked      '合并假结点
      chkCOD.Value = vbUnchecked      '去除短悬线
      chkEDL.Value = vbUnchecked      '延长长悬线
End Sub

Private Sub chkNetTopu_Click()       '创建网络拓扑图层
      If chkNetTopu.Value = 1 Then
            txtNetName.Enabled = True
            txtNetName.BackColor = &H80000005
            txtNetName.SetFocus
      Else
            txtNetName.BackColor = &H8000000B
            txtNetName.Enabled = False
      End If
End Sub

Private Sub chkTopuPolygon_Click()   '创建拓扑多边形
      If chkTopuPolygon.Value = 1 Then
            txtPolygonName.Enabled = True
            txtPolygonName.BackColor = &H80000005
            txtPolygonName.SetFocus
      Else
            txtPolygonName.BackColor = &H8000000B
            txtPolygonName.Enabled = False
      End If
End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
      If SSTab1.Tab = 1 Then txtFuzzy.SetFocus
End Sub

Private Sub txtDangle_GotFocus()
      lblDescription.Caption = "Dangle 容限指定建立拓扑关系时可以删除的过头线的最大长度。" & _
                              "系统默认为图层范围的1/10000。"
End Sub

Private Sub txtFuzzy_GotFocus()
      lblDescription.Caption = "Fuzzy 容限即是图层的精度（分辨率），代表顶点（Vertex）和结点" & _
                  "（Node）之间的最小距离。也就是说，再此距离之内的两个点可以视为重合。Fuzzy" & _
                  "容限一般为图层范围的1/10000 -- 1/1000000之间。为确保地图精度，本系统默认为" & _
                  "1/1000000，适于建立拓扑关系。"
End Sub

Private Sub txtGrain_GotFocus()
      lblDescription.Caption = "Grain 容限用于控制圆、弧线、曲线转换成折线时的取点密度。适用于地图编辑。系统默认为图层范围的1/10000。"
End Sub

Private Sub txtNodesnap_GotFocus()
      lblDescription.Caption = "Node snap 容限适用于地图编辑。可以把当前编辑的点或线连接到图层" & _
                  "中已经存在的对象的结点上。该容限对于封闭一个多边形以及去掉过头线（overshoots）和" & _
                  "undershoots非常重要，系统默认为图层范围的1/10000。"
End Sub

Private Sub txtSmallplygon_GotFocus()
      lblDescription.Caption = "Small plygon 容限用于指定建立拓扑关系时可以删除的最大碎多边形。本容限使用面积单位。"
End Sub