emme2 plugin.frm

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

      End
      Begin VB.Menu mnudelnode 
         Caption         =   "删除节点(&D)"
      End
      Begin VB.Menu mnunodesetup 
         Caption         =   "节点属性(&S)"
      End
      Begin VB.Menu mnusp3 
         Caption         =   "-"
      End
      Begin VB.Menu mnueditnode 
         Caption         =   "图元属性(&P)"
      End
   End
   Begin VB.Menu mnulink 
      Caption         =   "路段(&L)"
      Begin VB.Menu mnuaddlink 
         Caption         =   "添加路段(&A)"
      End
      Begin VB.Menu mnudeletelink 
         Caption         =   "删除路段(&D)"
      End
      Begin VB.Menu mnulinksetup 
         Caption         =   "路段属性(&S)"
      End
      Begin VB.Menu sp4 
         Caption         =   "-"
      End
      Begin VB.Menu mnueditlink 
         Caption         =   "图元属性(&P)"
      End
   End
   Begin VB.Menu mnutheme 
      Caption         =   "专题图(&P)"
      Begin VB.Menu mnucreatetheme 
         Caption         =   "创建专题图(&C)"
      End
      Begin VB.Menu mnuedittheme 
         Caption         =   "修改专题图(&E)"
      End
      Begin VB.Menu mnueditlegend 
         Caption         =   "修改图例(&L)"
      End
   End
   Begin VB.Menu mnuTools 
      Caption         =   "工具(&T)"
      Begin VB.Menu mnuToolsArrow 
         Caption         =   "箭头(&A)"
      End
      Begin VB.Menu mnuToolsZoomIn 
         Caption         =   "放大(&I)"
      End
      Begin VB.Menu mnuToolsZoomOut 
         Caption         =   "缩小(&O)"
      End
      Begin VB.Menu mnuToolsPan 
         Caption         =   "漫游(&P)"
      End
      Begin VB.Menu mnuToolsRuler 
         Caption         =   "标尺(&R)"
      End
      Begin VB.Menu mnusptool 
         Caption         =   "-"
      End
      Begin VB.Menu mnuToolsSelect 
         Caption         =   "单点选择(&S)"
      End
      Begin VB.Menu mnuToolsSelectRectangle 
         Caption         =   "矩形选择"
      End
      Begin VB.Menu mnuToolsSelectRadius 
         Caption         =   "半径选择"
      End
      Begin VB.Menu mnuToolsSelectPolygon 
         Caption         =   "多边形选择"
      End
      Begin VB.Menu spp 
         Caption         =   "-"
      End
      Begin VB.Menu mnuToolsLabel 
         Caption         =   "标注(&L)"
      End
      Begin VB.Menu mnuToolsAddSymbolAnnotation 
         Caption         =   "符号(&S)"
      End
      Begin VB.Menu mnuToolsAddTextAnnotation 
         Caption         =   "文字(&T)"
      End
   End
   Begin VB.Menu mnuhelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnucontent 
         Caption         =   "帮助主题(&C)"
         Shortcut        =   {F1}
      End
      Begin VB.Menu bar4 
         Caption         =   "-"
      End
      Begin VB.Menu mnuupdate 
         Caption         =   "更新(&U)..."
      End
      Begin VB.Menu mnusupport 
         Caption         =   "技术支持(&T)"
      End
      Begin VB.Menu bar5 
         Caption         =   "-"
      End
      Begin VB.Menu mnuabout 
         Caption         =   "关于(&A)..."
      End
   End
   Begin VB.Menu mnuright 
      Caption         =   "popup"
      Visible         =   0   'False
      Begin VB.Menu mnuproper 
         Caption         =   "属性"
      End
      Begin VB.Menu mnusp1 
         Caption         =   "-"
      End
      Begin VB.Menu mnueditit 
         Caption         =   "编辑"
      End
      Begin VB.Menu mnudeleteit 
         Caption         =   "删除"
      End
   End
End
Attribute VB_Name = "Main"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*********************************************************************
'*
'*                本源码完全免费，共交通同仁学习参考                 *
'*                      www.tranbbs.com                              *
'*                   Developed by Yang Ming                          *
'*       Nanjing Institute of City Transportation Planning           *
'*                 请保留本版权信息，谢谢合作                        *
'*                      中国交通技术论坛                             *
'*                                                                   *
'*                                                                   *
'*********************************************************************

Option Explicit
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hWnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
'See Module1.bas for global variable declarations
Private Declare Function HtmlHelpA Lib "hhctrl.ocx" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long


Dim MouseDownX1 As Double   ' The ruler tool displays the distance as the mouse is moved.                            ' These variables store the point at which the mouse was pressed down
Dim MouseDownY1 As Double
Dim Mycancel As Boolean     ' Judge variable


Private Sub Form_Load()

    Mapshow.Left = 0
    Mapshow.Top = 380
'    Restore the settings that we saved in Form_Unload
    ExportFormat = GetSetting(App.Title, "Settings", "ExportFormat", miFormatBMP)
    ExportFormatString = GetSetting(App.Title, "Settings", "ExportFormatString", "Windows Bitmap")
    ExportFormatExt = GetSetting(App.Title, "Settings", "ExportFormatExt", "*.bmp")
    ExportWidth = GetSetting(App.Title, "Settings", "ExportWidth", 0#)
    ExportHeight = GetSetting(App.Title, "Settings", "ExportHeight", 0#)

    Mapshow.MapUnit = miUnitMeter
   
'    set the bounds of mapshow object be the layers bounds
    Set Mapshow.Bounds = Mapshow.Layers.Bounds
    
    ' mapshow.PaperUnit is the unit needed for the Map.ExportMap call
    ' and the unit that Map.MapPaperHeight and Map.MapPaperWidth
    ' returns.
    Mapshow.PaperUnit = miPaperUnitInch
    
    Dim Mybound As New mapxlib.Rectangle
    Mybound.Set -1, -1, 1000000, 1000000

    Mapshow.DisplayCoordSys.Set miNonEarth, , miUnitMeter, , , , , , , , , , Mybound
    Mapshow.NumericCoordSys.Set miNonEarth, , miUnitMeter, , , , , , , , , , Mybound
    Mapshow.AreaUnit = miUnitSquareMeter
    
    Mapshow.CreateCustomTool myNewRouteToolID, miToolTypePoly, 0
    Mapshow.CreateCustomTool myNewNodeToolID, miToolTypeCircle, miCrossCursor
    Mapshow.CreateCustomTool 101, miToolTypePoly, miCrossCursor
    
    Mapshow.MousePointer = miArrowCursor
    
    '刷新最近打开的文件
    Dim RecentStr(1 To 20) As String
    Dim LNum
    step = 0
    Open App.Path & "\setup\recent.dat" For Input As #1
    Do While Not EOF(1)
        step = step + 1
        Line Input #1, RecentStr(step)
    Loop
    Close #1
    
    LNum = step
    Dim i
    Open App.Path & "\setup\recent.dat" For Output As #1
    For i = LNum - 7 To LNum
        If i > 0 And i <= LNum Then
        Print #1, RecentStr(i)
        End If
    Next i
    Close #1
    
    

    Call MnuUnuse
    
    Load frmFront
    frmFront.Show
       
End Sub


Private Sub Form_Resize()

    Mapshow.Width = Me.Width
    Mapshow.Height = Me.Height
    Line1(1).X2 = Me.Width
    Line1(2).X2 = Me.Width


End Sub

Private Sub Form_Unload(Cancel As Integer)

   'close all open recordset you have forgotten and the end the application
    Close
    End


End Sub

Private Sub mapshow_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

     If Mapshow.CurrentTool = myNewNodeToolID And Button = 1 Then
        Mapshow.ConvertCoord x, y, X1, Y1, miScreenToMap
        Load NodeFrm
        NodeFrm.Show
     End If


End Sub

Private Sub Mapshow_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

  If Button = 2 Then
    PopupMenu mnuright, 2
  End If

End Sub




Private Sub Mapshow_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
        
        Mapshow.ConvertCoord x, y, LinkX, LinkY, miScreenToMap
        SbXY.Panels(1).Text = "X=" & LinkX
        SbXY.Panels(2).Text = "Y=" & LinkY
        
        Dim Pnt As New Point
        Dim Ftrs As Features
        Dim LyrNode As Layer
        If Mapshow.Layers.Count > 0 Then
            Set LyrNode = Mapshow.Layers("node")
            
            Pnt.Set LinkX, LinkY
            Mapshow.MousePointer = 0
            Set Ftrs = LyrNode.SearchAtPoint(Pnt)
            If Mapshow.CurrentTool = myNewRouteToolID Then
            Mapshow.MousePointer = 2
            SbXY.Panels(3).Text = "提示：添加路段时请注意鼠标指针的变化，确认路段起终点落在有效节点内！"
                If Ftrs.Count > 0 Then
                        Mapshow.MousePointer = miCustomCursor
                        Mapshow.MouseIcon = App.Path & "\setup\PALETTE.CUR"
                        SbXY.Panels(3).Text = "提示：已经锁定有效节点，节点编号为：" & Ftrs.Item(1).KeyValue
                End If
            End If
        End If
End Sub

Public Sub mapshow_SelectionChanged()
'如果禁止自动调用此过程，则退出
If gbForbidSelChanged Then Exit Sub

Dim selLink As Selection
Dim ffLink As FeatureFactory
Dim Ftr As Feature
Dim db As Connection
Dim rs As Recordset
Dim sConn As String, sCmd As String

Dim iLink1 As Integer, iLink2 As Integer
Dim iStart1 As Integer, iStart2 As Integer, iEnd1 As Integer, iEnd2 As Integer
   
   ''/*************
   Dim Ftr1 As Feature
   Dim Lyr As Layer
   Dim Ftrname As String
   
   frmSelectionWindow.List1.Clear
   frmSelectionWindow.Combo1.Clear
      
    Call DelFea
     
     
  
      
End Sub

Private Sub mnuabout_Click()
Load frmAbout
frmAbout.Show
End Sub

Private Sub mnuaddlayers_Click()
    Dim sFile As String
    
    On Error GoTo MapErr
    ' Show the open dialog to add a layer
    With dlgCommonDialog
        .DialogTitle = "Add Layer"
        .Flags = 0
        '.Flags = cdlOFNAllowMultiselect ' Let the user select multiple tables to add
        .CancelError = True
        .FileName = ""
        .Filter = "MapInfo Tables (*.tab)|*.tab"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    
    ' Add the layer to the current map
    
    Dim Lyr As Layer
    Set Lyr = Mapshow.Layers.Add(sFile)
    If Lyr.Type <> miLayerTypeRaster Then
        Mapshow.Layers.Remove Lyr
        MsgBox "该文件不是有效的栅格图文件，请重新选择！"
        Exit Sub
    Else
    Main.Mapshow.Bounds = Lyr.Bounds
    End If
    
    Exit Sub
MapErr:
    If Err <> 32755 Then ' 32755 : Cancel was selected
        MsgBox "Could not add layer: """ & sFile & """. Error #" & Str(Err) & ": " & Error
    End If
End Sub

Private Sub mnuaddlink_Click()
Mapshow.CurrentTool = myNewRouteToolID
End Sub

Private Sub mnuaddnode_Click()
Mapshow.CurrentTool = myNewNodeToolID
Toolbar1.Refresh
End Sub

Private Sub mnuclose_Click()
    Unload Me
End Sub

Private Sub mnucloseproject_Click()
    
    Mapshow.Layers.RemoveAll
    Set mDbBiblio = Nothing
    MnuUnuse
    
End Sub

Private Sub mnucontent_Click()

Dim tempstr
tempstr = App.Path & "\HELP.CHM::/html/MAIN.htm"
HtmlHelpA Main.hWnd, tempstr, 0, 0

End Sub

Private Sub mnucreatetheme_Click()
    Load frmCreateTheme
    frmCreateTheme.Show
    
End Sub

Private Sub mnudatamanage_Click()
    Load FrmDbManage
    FrmDbManage.Show
End Sub

Private Sub mnudeleteit_Click()
 
On Error Resume Next

    Toolbar1.Refresh
    Mapshow.CurrentTool = miSelectTool
    
   
    Dim FtrSel As Feature
    Dim FtrSels As Feature
    Dim FtrInter As Feature
    Dim Fs As Features
    Dim NewFt As Features
    
    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 FidId As Long
    Dim LinkFidId As Long
    Dim RsDel As Recordset
    Dim RespDel
    
     Set Lyr = Mapshow.Layers.Item("Node")
     For Each FtrSel In Lyr.Selection
        
                '首先从数据库中删除记录
                 Fid = Lyr.KeyField
                 FidId = FtrSel.KeyValue

                RespDel = MsgBox("删除该节点的同时将删除与之相连的路段，而且本操作不可恢复，根据网络节点数量" & vbCrLf & "可能需要较长时间搜索邻接路段，确定删除该节点吗？", vbOKCancel, "删除对象")
                
                If RespDel = vbOK Then
            
                '首先删除相连的路段
                SbXY.Panels(3).Text = "正在删除，请稍候..."
                Set Fs = LyrLink.AllFeatures
                Dim stval, pro
                pro = 0
                
                If Fs.Count <> 0 Then
                    stval = 100 / Fs.Count
                End If
                
                Load FrmProgress
                FrmProgress.Show
                
                For Each FtrInter In Fs
                    
                    pro = pro + stval
                    step = Int(pro)
                    Call Progress(pro, "检查节点属性并删除选中节点")
                    
                If Mapshow.FeatureFactory.IntersectionTest(FtrSel, FtrInter, miIntersectFeature) = True Then
                    
                    Dim Ptas, Ptbs As Points
                    Dim Pta, Ptb As Point
                    Dim fa, fb, FtrTemp1, FtrTemp2 As Feature