emme2 plugin.frm

一个交通专用的gis-T系统

                    Set Ptas = FtrInter.Parts.Item(1)
                    Set Ptbs = FtrInter.Parts.Item(FtrInter.Parts.Count)
                    Set Pta = Ptas.Item(1)
                    Set Ptb = Ptbs.Item(Ptbs.Count)

                    Set fa = Main.Mapshow.FeatureFactory.CreateCircularRegion(1, Pta, NodeRadius, 7, 32)
                    Set FtrTemp1 = LyrLink.AddFeature(fa)
                    
                    If Mapshow.FeatureFactory.IntersectionTest(FtrSel, FtrTemp1, miIntersectFeature) = True Then
                            LinkFidId = FtrInter.KeyValue
                            Set RsDel = mDbBiblio.OpenRecordset("select * from Links where LinkId=" & LinkFidId)
                            If RsDel.RecordCount > 0 Then
                                RsDel.Delete
                            End If
                            LyrLink.DeleteFeature FtrTemp1
                            LyrLink.DeleteFeature FtrInter
                    Else
                            LyrLink.DeleteFeature FtrTemp1
                    End If

                    Set fb = Main.Mapshow.FeatureFactory.CreateCircularRegion(1, Ptb, NodeRadius, 7, 32)
                    Set FtrTemp2 = LyrLink.AddFeature(fb)
                    
                    If Mapshow.FeatureFactory.IntersectionTest(FtrSel, FtrTemp2, miIntersectFeature) = True Then
                            LinkFidId = FtrInter.KeyValue
                            Set RsDel = mDbBiblio.OpenRecordset("select * from Links where LinkId=" & LinkFidId)
                            If RsDel.RecordCount > 0 Then
                                RsDel.Delete
                            End If
                            LyrLink.DeleteFeature FtrTemp2
                            LyrLink.DeleteFeature FtrInter
                    Else
                            LyrLink.DeleteFeature FtrTemp2
                    End If
                    
                    End If
                   
                
                
                Next
                Unload FrmProgress
                '删除该节点
                Set RsDel = mDbBiblio.OpenRecordset("select * from Nodes where NodeId=" & FidId)
                RsDel.Delete
                Lyr.DeleteFeature FtrSel
                
                Set RsDel = Nothing
                Mapshow.MousePointer = 2
                SbXY.Panels(3).Text = "删除成功！请继续其他操作！"
                
            Else
            
                Toolbar1.Buttons(23).Value = tbrUnpressed
                Toolbar1.Refresh
                Exit Sub
                
            End If

        
     Next

     Set Lyr = Mapshow.Layers.Item("Link")
     For Each FtrSel In Lyr.Selection
        
       '首先从数据库中删除记录
        Fid = Lyr.KeyField
        FidId = FtrSel.KeyValue
   
            RespDel = MsgBox("本操作不可恢复，确定删除该路段吗？", vbOKCancel, "删除对象")
            If RespDel = vbOK Then
                Set RsDel = mDbBiblio.OpenRecordset("select * from Links where LinkId=" & FidId)
                If RsDel.RecordCount > 0 Then
                    RsDel.Delete
                End If
                Set RsDel = Nothing
                Lyr.DeleteFeature FtrSel
            Else
                Toolbar1.Buttons(23).Value = tbrUnpressed
                Toolbar1.Refresh
                Exit Sub
            End If
     Next
    
    
    Toolbar1.Buttons(23).Value = tbrUnpressed
    Toolbar1.Refresh
    
End Sub

Private Sub mnudeletelink_Click()
mnuproper_Click
End Sub

Private Sub mnudelimg_Click()
mnudeleteit_Click
End Sub

Private Sub mnudelnode_Click()
mnudeleteit_Click
End Sub

Private Sub mnudir_Click()
Load Frmwizard
Frmwizard.Show
End Sub

Private Sub mnueditit_Click()

    
    Mapshow.CurrentTool = miSelectTool
    Toolbar1.Refresh
    
    Dim FtrSel As Feature
    Dim FtrSels As Feature
    
    Dim Lyr As Layer
    Dim LyrNode As Layer
    Dim LyrLink As Layer
    Set LyrNode = Mapshow.Layers("Node")
    Set LyrLink = Main.Mapshow.Layers("Link")
    
    Dim Fid As String

    Dim LinkFidId As Long
    Dim RsDel As Recordset
    Dim RespDel
    
    Set Lyr = Main.Mapshow.Layers("Node")
     For Each FtrSel In Lyr.Selection
        '首先从数据库中删除记录
        Fid = Lyr.KeyField
        FidIdEdit = FtrSel.KeyValue
        
            X1 = FtrSel.CenterX
            Y1 = FtrSel.CenterY
        
            Load NodeFrmEdit
            NodeFrmEdit.Show

     Next
     
    Set Lyr = Main.Mapshow.Layers("Link")
     For Each FtrSel In Lyr.Selection
        '首先从数据库中删除记录
        Fid = Lyr.KeyField
        FidIdEdit = FtrSel.KeyValue

            LinkLength = FtrSel.Length
            Load FrmLinkEdit
            FrmLinkEdit.Show

     Next

End Sub

Private Sub mnueditlink_Click()
    Load FrmLinkSetup
    FrmLinkSetup.Show
End Sub

Private Sub mnueditnode_Click()
    Load FrmNodeSetup
    FrmNodeSetup.Show
End Sub

Private Sub mnuexportmap_Click()
ExportMap Main
End Sub

Private Sub mnufindplace_Click()
    Load SpotPlace
    SpotPlace.Show
    
End Sub

Private Sub mnulayerscontrol_Click()
    Mapshow.Layers.LayersDlg
End Sub

Private Sub mnulinksetup_Click()
mnuproper_Click
End Sub

Private Sub mnunewproject_Click()
    Load frmFront
    frmFront.Show
End Sub

Private Sub mnunodesetup_Click()
mnuproper_Click
End Sub


Private Sub mnuopenproject_Click()
    Load frmexport
    frmexport.Show
End Sub

Private Sub mnuprint_Click()
    frmPrint.Show vbModal
End Sub

Public Sub mnuprintsetup_Click()
On Error Resume Next
With CdlExportMap
    .PrinterDefault = True 'False  ''
    .Flags = cdlPDPrintSetup + cdlPDReturnDC
    .ShowPrinter
    Printer.Orientation = .Orientation
End With

End Sub


Private Sub mnuproper_Click()

On Error Resume Next
    
    Mapshow.CurrentTool = miSelectTool
    Toolbar1.Refresh
    
    Dim FtrSel As Feature
    Dim FtrSels As Features
    
    Dim Lyr As mapxlib.Layer
    Dim Fid As String

    Dim LinkFidId As Long
    Dim RsDel As Recordset
    Dim RespDel
    
    Dim SelNum
    SelNum = 0
    For Each Lyr In Mapshow.Layers
         SelNum = SelNum + Lyr.AllFeatures.Count
    Next
    If SelNum = 0 Then
        MsgBox "请选择对象查看！"
        Exit Sub
    End If
    
    step = 0
    Set Lyr = Mapshow.Layers("Node")
    For Each FtrSel In Lyr.Selection
        step = step + 1
    Next

    If step <> 0 Then
        If step > 1 Then
        MsgBox "选择的节点超过1个，软件只显示编号在前的节点属性！"
        End If
        For Each FtrSel In Lyr.Selection
            '首先从数据库中删除记录
            Fid = Lyr.KeyField
            FidIdEdit = FtrSel.KeyValue
            X1 = FtrSel.CenterX
            Y1 = FtrSel.CenterY
            Load NodeFrmEdit
            NodeFrmEdit.Show
        Next
        
    End If
    
    Set Lyr = Mapshow.Layers("Link")
    step = 0
    For Each FtrSel In Lyr.Selection
        step = step + 1
    Next

    If step <> 0 Then
        If step > 1 Then
        MsgBox "选择的路段超过1个，软件只显示编号在前的路段属性！"
        End If
    
        For Each FtrSel In Lyr.Selection
           '首先从数据库中删除记录
                Fid = Lyr.KeyField
                FidIdEdit = FtrSel.KeyValue
               LinkLength = FtrSel.Length
               Load FrmLinkEdit
               FrmLinkEdit.Show
        Next
     End If
  

End Sub



Private Sub mnusearch_Click()
    Load FrmSearch
    FrmSearch.Show
End Sub

Private Sub openproject_Click()


    Dim sFile As String
    Dim sDir As String
'
    On Error GoTo MapErr
    
    With dlgCommonDialog
        .DialogTitle = "Open"
        .Flags = 0
        .CancelError = False
        .FileName = ""
        .Filter = "GIS-T Interface Files (*.mdb)|*.mdb"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
     
    End With
    Set mDbBiblio = DBEngine.Workspaces(0).OpenDatabase(sFile)

    Dim FilePlace
    FilePlace = InStrRev(sFile, "\")
        
    sDir = Left(sFile, FilePlace)
    Dim Lyr As mapxlib.Layer
    ProjectPath = sDir
    MDBPath = sFile
    
    Mapshow.Layers.Add sDir & "link.tab"
    Mapshow.Layers.Add sDir & "node.tab"
    Set Lyr = Mapshow.Layers("Link")
    Mapshow.Bounds = Lyr.Bounds
    
    
    Open ProjectPath & "setup.ini" For Input As #1
    Do While Not EOF(1)
    Input #1, NodeRadius, NodeColor, LinkWidth, LinkColor
    Loop
    Close #1
    
    Open App.Path & "\setup\recent.dat" For Append As #1
    Print #1, sFile
    Close #1

    Call MnuControl
    Exit Sub
       
    
MapErr:
    
    Dim RespErr
    RespErr = MsgBox("打开项目错误，请检查项目文件是否完整！", vbExclamation, "项目打开错误！")
    Close #1
    
End Sub

Private Sub readvolume_Click()

Load FrmImportVolume
FrmImportVolume.Show

        
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
 
 On Error Resume Next
    Dim i
    Dim j
    j = Button.Index
    For i = 1 To 25
        Toolbar1.Buttons(i).Value = tbrUnpressed
    Next i
    If j > 5 Then
        Toolbar1.Buttons(j).Value = tbrPressed
    End If
    If j = 21 Or j = 22 Then
        Toolbar1.Buttons(j).Value = tbrUnpressed
    End If
    
    Toolbar1.Refresh
    
    Select Case Button.Key
        Case "New"
            mnunewproject_Click
        Case "Open"
            openproject_Click
        Case "Print"
            mnuprint_Click
        Case "layer"
            mnulayerscontrol_Click
        Case "Arrow"
            mnuToolsArrow_Click
        Case "Zoom In"
            mnuToolsZoomIn_Click
        Case "Zoom Out"
            mnuToolsZoomOut_Click
        Case "Pan"
            mnuToolsPan_Click
        Case "Ruler"
            mnuToolsRuler_Click
        Case "Select"
            mnuToolsSelect_Click
        Case "Select Rectangle"
            mnuToolsSelectRectangle_Click
        Case "Select Radius"
            mnuToolsSelectRadius_Click
        Case "Select Polygon"
            mnuToolsSelectPolygon_Click
        Case "Label"
            mnuToolsLabel_Click
        Case "Add Symbol Annotation"
            mnuToolsAddSymbolAnnotation_Click
        Case "Add Text Annotation"
            mnuToolsAddTextAnnotation_Click
        Case "Add Node"
            mnuaddnode_Click
        Case "Add Link"
        mnuaddlink_Click
        Case "delete"
        mnudeleteit_Click
        Case "proper"
           mnuproper_Click
        Case "search"
           mnusearch_Click
        
    End Select
    
End Sub
Private Sub mnuToolsRuler_Click()

    Main.Mapshow.CurrentTool = 101
    frmRuler.Show

            mnuToolsArrow.Checked = False
            mnuToolsZoomIn.Checked = False
            mnuToolsZoomOut.Checked = False
            mnuToolsPan.Checked = False
            mnuToolsRuler.Checked = True
            mnuToolsSelect.Checked = False
            mnuToolsSelectRectangle.Checked = False
            mnuToolsSelectRadius.Checked = False
            mnuToolsSelectPolygon.Checked = False
            mnuToolsLabel.Checked = False
            mnuToolsAddSymbolAnnotation.Checked = False
            mnuToolsAddTextAnnotation.Checked = False
            
            Dim i
            For i = 1 To 25
                Toolbar1.Buttons(i).Value = tbrUnpressed
            Next i
                Toolbar1.Buttons(10).Value = tbrPressed
                Toolbar1.Refresh
    
    
End Sub


Private Sub mnuToolsAddSymbolAnnotation_Click()

    Mapshow.CurrentTool = miSymbolTool

            mnuToolsArrow.Checked = False
            mnuToolsZoomIn.Checked = False
            mnuToolsZoomOut.Checked = False