End
      Begin VB.Menu mnudelnode 
         Caption         =   "刪除節(jié)點(&D)"
      End
      Begin VB.Menu mnunodesetup 
         Caption         =   "節(jié)點屬性(&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         =   "創(chuàng)建專題圖(&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 = "提示：添加路段時請注意鼠標指針的變化，確認路段起終點落在有效節(jié)點內！"
                If Ftrs.Count > 0 Then
                        Mapshow.MousePointer = miCustomCursor
                        Mapshow.MouseIcon = App.Path & "\setup\PALETTE.CUR"
                        SbXY.Panels(3).Text = "提示：已經(jīng)鎖定有效節(jié)點，節(jié)點編號為：" & 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
        
                '首先從數(shù)據(jù)庫中刪除記錄
                 Fid = Lyr.KeyField
                 FidId = FtrSel.KeyValue

                RespDel = MsgBox("刪除該節(jié)點的同時將刪除與之相連的路段，而且本操作不可恢復，根據(jù)網(wǎng)絡節(jié)點數(shù)量" & vbCrLf & "可能需要較長時間搜索鄰接路段，確定刪除該節(jié)點嗎？", 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, "檢查節(jié)點屬性并刪除選中節(jié)點")
                    
                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