frmtopo.frm

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

      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         Caption         =   "网络图层名"
         Height          =   195
         Index           =   0
         Left            =   2385
         TabIndex        =   6
         Tag             =   "3261"
         Top             =   690
         Width           =   900
      End
   End
   Begin VB.Image Image1 
      Appearance      =   0  'Flat
      BorderStyle     =   1  'Fixed Single
      Height          =   1185
      Left            =   0
      Picture         =   "frmTopo.frx":006D
      Stretch         =   -1  'True
      Top             =   0
      Width           =   5295
   End
End
Attribute VB_Name = "frmTopo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

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 cmbDtPt_Click()
    If cmbDtPt.Text = "" Then
        txtFlt.Enabled = False
        txtFlt.BackColor = &H8000000B
    Else
        txtFlt.Enabled = True
        txtFlt.BackColor = vbWhite
    End If
End Sub

Private Sub cmdAdvance_Click()
    If cmdAdvance.Caption = "高级设置" Then
        frameAdvance.Visible = True
        cmdOk.Enabled = False
        cmdAdvance.Caption = "<<"
    Else
        frameAdvance.Visible = False
        cmdOk.Enabled = True
        cmdAdvance.Caption = "高级设置"
    End If
End Sub

Private Sub cmdCancel_Click()
    Unload Me
End Sub

Private Sub cmdClear_Click()
    Dim objDs As soDataSource
    Dim objDtVector As soDatasetVector
    Dim objError As New soError
    Dim strName As String
    
    strName = frmMain.strDs
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(strName)
    If objDs Is Nothing Then
        MsgBox objError.LastErrorMsg, vbInformation
        Set objError = Nothing
        Exit Sub
    End If
    strName = frmMain.strDt
    Set objDtVector = objDs.Datasets.Item(strName)
    If objDtVector Is Nothing Then
        MsgBox objError.LastErrorMsg, vbInformation
        Set objDs = Nothing
        Set objError = Nothing
        Exit Sub
    End If
    objDtVector.EmptyTolerance
    txtFuzzy.Text = "0"
    txtDangle.Text = "0"
    txtNodesnap.Text = "0"
    txtSmallplygon.Text = "0"
    txtGrain.Text = "0"
    Set objDtVector = Nothing
    Set objDs = Nothing
    Set objError = Nothing
End Sub

Private Sub cmdDefault_Click()
    '设置系统的默认值
    Dim objDtVector As soDatasetVector
    Dim objDs As soDataSource
    Dim objError As New soError
    Dim strName As String
    
    strName = frmMain.strDs
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(strName)
    If objDs Is Nothing Then
        MsgBox objError.LastErrorMsg, vbInformation
        Set objError = Nothing
        Exit Sub
    End If
    strName = frmMain.strDt
    Set objDtVector = objDs.Datasets.Item(strName)
    If objDtVector Is Nothing Then
        MsgBox objError.LastErrorMsg, vbInformation
        Set objDs = Nothing
        Set objError = Nothing
        Exit Sub
    End If
    
    objDtVector.SetToleranceToDefault
    
    Set objDs = Nothing
    Set objDtVector = Nothing
    Set objError = Nothing
End Sub

Private Sub cmdOk_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 objDs As soDataSource
    Dim objDt As soDataset
    Dim objDtPt As soDataset
    Dim objError As New soError
    
    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.strDs
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(strDsName)
    If objDs Is Nothing Then
        MsgBox objError.LastErrorMsg, vbInformation
        Set objError = Nothing
        Exit Sub
    Else
        '检查网络拓扑时数据集名称的合法性
        If bNetTopu Then
            If objDs.IsAvailableDatasetName(strNetName) = False Then      '网络图层名称非法
                MsgBox " 网络数据集名称非法！  ", vbInformation
                txtNetName.SetFocus
                Set objError = Nothing
                Exit Sub
            End If
        End If
        '检查多边形拓扑时数据集名称的合法性
        If bTopuPolygon = True Then
            If objDs.IsAvailableDatasetName(strPolygonName) = False Then   '多边形图层名称非法
                MsgBox " 多边形数据集名称非法！  ", vbInformation
                txtPolygonName.SetFocus
                Set objError = Nothing
                Exit Sub
            End If
        End If
    End If
    
    Set objDt = objDs.Datasets.Item(frmMain.strDt)
    If objDt Is Nothing Then
        MsgBox objError.LastErrorMsg, vbInformation
        Set objDs = Nothing
        Set objError = Nothing
        Exit Sub
    End If
    '进行相应选项的拓扑分析
    Dim objDtVector As soDatasetVector
    Set objDtVector = objDs.Datasets.Item(frmMain.strDt)
    
    objDtVector.ToleranceDangle = CDbl(Val(Trim$(txtDangle.Text)))
    objDtVector.ToleranceFuzzy = CDbl(Val(Trim$(txtFuzzy.Text)))
    objDtVector.ToleranceGrain = CDbl(Val(Trim$(txtGrain.Text)))
    objDtVector.ToleranceNodeSnap = CDbl(Val(Trim$(txtNodesnap.Text)))
    objDtVector.ToleranceSmallPolygon = CDbl(Val(Trim$(txtSmallplygon.Text)))
    
    If cmbDtPt.Text <> "" Then
        Set objDtPt = objDs.Datasets(cmbDtPt.Text)
        If objDtPt.Type = scdPoint Then
            frmMain.SuperTopo.Filter.IdentityPointDataset = objDtPt
            frmMain.SuperTopo.Filter.EdgeFilter = Trim(txtFlt.Text)
            frmMain.SuperTopo.Filter.Tolerance = CDbl(txtFltTlr.Text)
        End If
    End If
    With frmMain.SuperTopo
        .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 objDt
    End With
    
    If chkErrInfo.Value = vbChecked Then
        frmMain.SuperTopo.CheckErrors objDt
    End If
    
    If bNetTopu Then              '建立网络拓扑
        bResult = False
        bResult = frmMain.SuperTopo.BuildNetwork(objDt, objDs, strNetName)
        If bResult = True Then
            frmMain.SuperWkspManager1.Refresh
        End If
    End If
    
    If bTopuPolygon Then          '建立拓扑多边形
        bResult = False
        bResult = frmMain.SuperTopo.BuildPolygons(objDt, objDs, strPolygonName)
        If bResult Then
            frmMain.SuperWkspManager1.Refresh
        End If
    End If
      
    Set objDs = Nothing
    Set objDt = Nothing
    Set objError = Nothing
    Unload Me
End Sub

Private Sub Form_Load()
    Dim objDtVector As soDatasetVector
    Dim objDs As soDataSource
    Dim objError As New soError
    Dim strName As String
    
    strName = frmMain.strDs
    Set objDs = frmMain.SuperWorkspace.Datasources.Item(strName)
    If objDs Is Nothing Then
        MsgBox objError.LastErrorMsg, vbInformation
        Set objError = Nothing
        Exit Sub
    End If
    strName = frmMain.strDt
    Set objDtVector = objDs.Datasets.Item(strName)
    If objDtVector Is Nothing Then
        MsgBox objError.LastErrorMsg, vbInformation
        Set objDs = Nothing
        Set objError = Nothing
        Exit Sub
    End If
    txtDangle.Text = objDtVector.ToleranceDangle
    txtFuzzy.Text = objDtVector.ToleranceFuzzy
    txtGrain.Text = objDtVector.ToleranceGrain
    txtNodesnap = objDtVector.ToleranceNodeSnap
    txtSmallplygon.Text = objDtVector.ToleranceSmallPolygon
    
    InitCmpDtPt
    
    Set objDs = Nothing
    Set objDtVector = Nothing
    Set objError = Nothing
    frameAdvance.Left = 0
    frameAdvance.Top = 1185
End Sub

Public Sub InitCmpDtPt()
    Dim objDs As soDataSource
    Dim objDt As soDataset
    Dim i As Integer
    Dim iCnt As Integer
    
    Set objDs = frmMain.SuperWorkspace.Datasources(1)
    iCnt = objDs.Datasets.Count
    If iCnt > 0 Then
        cmbDtPt.Clear
        cmbDtPt.AddItem ""
        For i = 1 To iCnt
            Set objDt = objDs.Datasets(i)
            If objDt.Type = scdPoint Then
                cmbDtPt.AddItem objDt.Name
            End If
        Next i
    Else
        cmbDtPt.Clear
        cmbDtPt.AddItem ""
    End If
    cmbDtPt.ListIndex = 0
    
    Set objDt = Nothing
    Set objDs = Nothing
End Sub

Private Sub txtDangle_Change()
    If Trim(txtDangle.Text = "") Then txtDangle.Text = 0
End Sub

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

Private Sub txtFltTlr_Change()
    If Trim(txtFltTlr.Text = "") Then txtFltTlr.Text = 0
End Sub

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

Private Sub txtFuzzy_Change()
    If Trim(txtFuzzy.Text = "") Then txtFuzzy.Text = 0
End Sub

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

Private Sub txtGrain_Change()
    If Trim(txtGrain.Text = "") Then txtGrain.Text = 0
End Sub

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

Private Sub txtNodesnap_Change()
    If Trim(txtNodesnap.Text = "") Then txtNodesnap.Text = 0
End Sub

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

Private Sub txtSmallplygon_Change()
    If Trim(txtSmallplygon.Text = "") Then txtSmallplygon.Text = 0
End Sub

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