武公交查询系统.frm

mo在地图制作中的介绍

      Begin VB.Menu sep6 
         Caption         =   "-"
      End
      Begin VB.Menu pan 
         Caption         =   "漫游"
      End
      Begin VB.Menu sep7 
         Caption         =   "-"
      End
      Begin VB.Menu fullextent 
         Caption         =   "全图"
      End
   End
   Begin VB.Menu view 
      Caption         =   "视图"
      Begin VB.Menu fullscreen 
         Caption         =   "全屏显示"
      End
      Begin VB.Menu sep8 
         Caption         =   "-"
      End
      Begin VB.Menu extent 
         Caption         =   "一般显示"
      End
      Begin VB.Menu sep13 
         Caption         =   "-"
      End
      Begin VB.Menu toolbar 
         Caption         =   "工具栏"
         Checked         =   -1  'True
      End
   End
   Begin VB.Menu fing 
      Caption         =   "查询"
      Begin VB.Menu findpoint 
         Caption         =   "站点查询"
      End
      Begin VB.Menu sep1 
         Caption         =   "-"
      End
      Begin VB.Menu findline 
         Caption         =   "路线查询"
      End
      Begin VB.Menu sep3 
         Caption         =   "-"
      End
      Begin VB.Menu fingchange 
         Caption         =   "换乘查询"
      End
      Begin VB.Menu sep12 
         Caption         =   "-"
      End
      Begin VB.Menu jingdian 
         Caption         =   "景点查询"
      End
   End
   Begin VB.Menu measure 
      Caption         =   "测量"
      Begin VB.Menu MeaLength 
         Caption         =   "测量线路长度"
      End
      Begin VB.Menu sep10 
         Caption         =   "-"
      End
      Begin VB.Menu MeaPerimeter 
         Caption         =   "测量多边形周长"
      End
      Begin VB.Menu sep11 
         Caption         =   "-"
      End
      Begin VB.Menu MeaArea 
         Caption         =   "测量多边形面积"
      End
   End
   Begin VB.Menu help 
      Caption         =   "帮助"
      Begin VB.Menu about 
         Caption         =   "关于"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim dr1 As DrawRect
Dim whichButton As MSComctlLib.Button

Private Sub Map1_AfterLayerDraw(ByVal index As Integer, ByVal canceled As Boolean, ByVal hdc As StdOle.OLE_HANDLE)
    
    If index = 0 Then Map2.TrackingLayer.Refresh True
    
End Sub               '显示缩略图功能

Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As StdOle.OLE_HANDLE)

  Dim sym As New Symbol
  sym.OutlineColor = moRed
  sym.Style = moTransparentFill
  Map2.DrawShape Map1.extent, sym
  
End Sub              '显示缩略图功能

Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

  Dim p As Point
  Set p = Map2.ToMapPoint(X, Y)
  If Map1.extent.IsPointIn(p) Then
    Set dr1 = New DrawRect
    dr1.DragStart Map1.extent, Map2, X, Y
  End If
  
End Sub               '显示缩略图功能

Private Sub Map2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  
  If Not dr1 Is Nothing Then
    dr1.DragMove X, Y
  End If
  
End Sub                '显示缩略图功能

Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  
  If Not dr1 Is Nothing Then
    Map1.extent = dr1.DragFinish(X, Y)
    Set dr1k = Nothing
  End If
  
End Sub                '显示缩略图功能


Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim bKey As String
  bKey = Button.Key
  Call doTask(bKey)
  BarState = bKey
End Sub                'task函数

Private Sub open_Click()

 Call doTask("open")
 
End Sub                '打开功能

Private Sub save_Click()

Call doTask("save")

End Sub                '保存功能

Private Sub file_print_Click()

Call doTask("print")
  
End Sub                '打印功能

Private Sub in_Click()
 
 Call doTask("zoomin")
 
End Sub                '放大功能

Private Sub out_Click()
 
 Call doTask("zoomout")
 
End Sub                '缩小功能


Private Sub fullextent_Click()

Call doTask("globe")

End Sub                '全图功能

Private Sub findpoint_Click()

 Call doTask("findpoint")

End Sub                 '站点查询

Private Sub findline_Click()

Call doTask("findline")

End Sub                  '路线查询

Private Sub fingchange_Click()

Call doTask("findchange")

End Sub                 '换乘查询

Private Sub jingdian_Click()

Call doTask("jingdian")

End Sub                   '景点查询

Private Sub about_Click()

Call doTask("about")

End Sub                   '关于

Private Sub MeaLength_Click()

str = "MeaLength"
Map1.MousePointer = moPencil

End Sub                 '测长度


Private Sub MeaPerimeter_Click()

str = "MeaPerimeter"
Map1.MousePointer = moPencil

End Sub                  '测周长

Private Sub MeaArea_Click()

str = "MeaArea"
Map1.MousePointer = moPencil
  
End Sub                 '测面积

Private Sub add_Click()

Call doTask("graphics")

End Sub              '添加图形元素

Private Sub fullscreen_Click()

Call doTask("fullscreen")

End Sub                   '全屏显示

Private Sub extent_Click()

Call doTask("extent")

End Sub

Public Sub doTask(buttonKey As String)
 Select Case buttonKey
    
        Case "open"      '打开

             CommonDialog1.Filter = "ESRI Shapefiles (*.shp)|*.shp|(*.*)|*.*"
      
             CommonDialog1.CancelError = True
             On Error GoTo ErrorTrap
             CommonDialog1.ShowOpen
             
             If CommonDialog1.FilterIndex = 2 Then
                imlayer.file = CommonDialog1.FileTitle
                Map1.Layers.add imlayer
                Map2.Layers.add imlayer
                Exit Sub
             End If
             
             If CommonDialog1.FilterIndex = 1 Then
                If Len(CommonDialog1.FileName) = 0 Then Exit Sub
                DC.Database = CurDir '路径=Left(.CommonDialog1.FileName, InStr(.CommonDialog1.FileName, .CommonDialog1.FileTitle) - 1)
                If Not DC.Connect Then
                   Exit Sub
                End If
                FName = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4)  '文件名
                Set gds = DC.FindGeoDataset(FName)
                If gds Is Nothing Then
                   Exit Sub
                Else
                   Set ShpLayer.GeoDataset = gds
                   Map1.Layers.add ShpLayer
                   Map2.Layers.add ShpLayer
                End If
                Set gds = Nothing
                Set ShpLayer = Nothing
                Exit Sub
             End If
ErrorTrap:
             If Err.Number <> 32755 Then 'Error is something other than Cancel
                MsgBox Err.Description, vbCritical
             End If           '打开

         Case "save"          '保存
              CommonDialog1.Filter = "ESRI Shapefiles (*.shp)|*.shp"
  
              'Set cancel error so that if cancel is used then we can trap it and exit
              CommonDialog1.CancelError = True
              On Error GoTo ErrorTrap1
              CommonDialog1.ShowSave
  
              If Len(CommonDialog1.FileName) = 0 Then Exit Sub
              DC.Database = CurDir '路径=Left(.CommonDialog1.FileName, InStr(.CommonDialog1.FileName, .CommonDialog1.FileTitle) - 1)
                If Not DC.Connect Then
                   Exit Sub
                End If
                FName = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4)  '文件名
             Call sav(addtype)
             Exit Sub
ErrorTrap1:
              If Err.Number <> 32755 Then 'Error is something other than Cancel
              MsgBox Err.Description, vbCritical
              End If
              Exit Sub                        '保存
             Case "zoomin"                    '放大
              If barGraphics.Visible = True Then barGraphics.Visible = False
              Map1.MousePointer = moZoomIn
         Case "zoomout"                        '缩小
              If barGraphics.Visible = True Then barGraphics.Visible = False
              Map1.MousePointer = moZoomOut
         Case "pan"                            '漫游
              If barGraphics.Visible = True Then barGraphics.Visible = False
              Map1.MousePointer = moPan
              
         Case "print"
          Form6.Show
          
         Case "findpoint"
         Form2.Show
         
         Case "findline"
         Form3.Show
         
         Case "findchange"
         Form4.Show
        
        Case "jingdian"
        Form7.Show
        
        Case "about"
        Form6.Show
        
        Case "globe"
        Set Map1.extent = Map1.fullextent
         Map1.MousePointer = moDefault