武公交查询系统.frm

mo在地图制作中的介绍

                  
        Case "graphics"                      '图形元素
               barGraphics.Visible = True
               barGraphics.Refresh
               Map1.MousePointer = moCross
         
        End Select
        
End Sub
Sub sav(tool As String)                         '保存函数

Dim lpoly As Long
 Select Case tool
       Case "point"                              '点保存"
              With desc
                ' define three additional fields
                .FieldCount = 3
            
                'set the field names
                .FieldName(0) = "Name"
                .FieldName(1) = "Area"
                .FieldName(2) = "Perimeter"
            
                ' set the type of field
                .FieldType(0) = moString
                .FieldType(1) = moDouble
                .FieldType(2) = moDouble
            
                ' set the length of a character field
            
                .FieldLength(0) = 16
            
                ' set the number of digits used in the field
                .FieldPrecision(1) = 15
                .FieldPrecision(2) = 15
            
                ' set the number of digits to the right of the decimal point
                .FieldScale(1) = 3
                .FieldScale(2) = 3
              End With

              Set gds = DC.AddGeoDataset(sName, moShapeTypePoint, desc)
              If gds Is Nothing Then Exit Sub   ' invalid file
            
                Set ShpLayer.GeoDataset = gds
                Map1.Layers.add ShpLayer
                Map2.Layers.add ShpLayer
                Map1.Refresh
                Map2.Refresh
            
              For lpoly = 1 To moPolygons.Count
            
                With ShpLayer.Records
                  .AddNew
                  .Fields("Shape").Value = moPolygons(lpoly)
                  .Fields("Name").Value = "Name " & lpoly
                  .Fields("Area").Value = 2#
                  .Fields("Perimeter").Value = 69
                  .Update
                End With
              Next
              ShpLayer.Records.StopEditing
       Case "line"                           '线保存
              With desc
               ' define three additional fields
                 .FieldCount = 3

                'set the field names
                .FieldName(0) = "Name"
                .FieldName(1) = "Area"
                .FieldName(2) = "Perimeter"
            
                ' set the type of field
                .FieldType(0) = moString
                .FieldType(1) = moDouble
                .FieldType(2) = moDouble
            
                ' set the length of a character field
            
                .FieldLength(0) = 16
            
                ' set the number of digits used in the field
                .FieldPrecision(1) = 15
                .FieldPrecision(2) = 15
            
                ' set the number of digits to the right of the decimal point
                .FieldScale(1) = 3
                .FieldScale(2) = 3
                End With

                Set gds = DC.AddGeoDataset(sName, moShapeTypeLine, desc)
                If gds Is Nothing Then Exit Sub   ' invalid file
                
                Set ShpLayer.GeoDataset = gds
                Map1.Layers.add ShpLayer
                Map2.Layers.add ShpLayer
                Map1.Refresh
                Map2.Refresh
                For lpoly = 1 To moPolygons.Count
                    With ShpLayer.Records
                      .AddNew
                      .Fields("Shape").Value = moPolygons(lpoly)
                      .Fields("Name").Value = "Name " & lpoly
                      .Fields("Area").Value = 2#
                      .Fields("Perimeter").Value = 69
                      .Update
                    End With
                 Next
                ShpLayer.Records.StopEditing
     Case "polygon"                         '多边形保存
             With desc
             ' define three additional fields
                  .FieldCount = 3

             'set the field names
                  .FieldName(0) = "Name"
                  .FieldName(1) = "Area"
                  .FieldName(2) = "Perimeter"

             ' set the type of field
                   .FieldType(0) = moString
                   .FieldType(1) = moDouble
                   .FieldType(2) = moDouble

             ' set the length of a character field

                    .FieldLength(0) = 16

             ' set the number of digits used in the field
                    .FieldPrecision(1) = 15
                    .FieldPrecision(2) = 15

             ' set the number of digits to the right of the decimal point
                    .FieldScale(1) = 3
                    .FieldScale(2) = 3
              End With

            Set gds = DC.AddGeoDataset(sName, moPolygon, desc)
            If gds Is Nothing Then Exit Sub   ' invalid file

              Set ShpLayer.GeoDataset = gds
              Map1.Layers.add ShpLayer
              Map2.Layers.add ShpLayer
              Map1.Refresh
              Map2.Refresh
  
            For lpoly = 1 To moPolygons.Count

                With ShpLayer.Records
                    .AddNew
                    .Fields("Shape").Value = moPolygons(lpoly)
                    .Fields("Name").Value = "Name " & lpoly
                    .Fields("Area").Value = moPolygons(lpoly).Area
                    .Fields("Perimeter").Value = moPolygons(lpoly).Perimeter
                    .Update
                End With
            Next
            ShpLayer.Records.StopEditing
   End Select
End Sub

Private Sub file_exit_Click()

End

End Sub                         '退出程序

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim tl As MapObjects2.TrackingLayer
Dim t2 As MapObjects2.TrackingLayer
Set tl = Map1.TrackingLayer
Set t2 = Map2.TrackingLayer
tl.SymbolCount = 3
t2.SymbolCount = 3
  Select Case Map1.MousePointer
      '调用放大缩小漫游地图函数
      Case moZoomIn
           zoomin Shift
      Case moZoomOut
           zoomout Shift
      Case moPan
           Map1.pan
     
         Case moPencil
           Dim LayerX As MapLayer
           Dim PointX As MapObjects2.Point
           Dim MeasureLine As New MapObjects2.Line
           Dim RecQuery As MapObjects2.Recordset           'the Recordset which was the Result of a query
           Dim MeasurePolygon As New MapObjects2.Polygon
         Select Case str
           Case "MeaLength"
            Set MeasureLine = Map1.TrackLine
            MsgBox "您所测量的线路的长度为" & Get2Decimal(CStr(MeasureLine.Length)) & "米", vbInformation, "测量结果"
            Set MeasureLine = Nothing
           
           Case "MeaPerimeter"
            Set MeasurePolygon = Map1.TrackPolygon
            Map1.FlashShape MeasurePolygon, 1
            MsgBox "您所测量的多边形周长为" & Get2Decimal(CStr(MeasurePolygon.Perimeter)) & "米", vbInformation, "测量结果"
            Set MeasurePolygon = Nothing
           
           Case "MeaArea"
            Set MeasurePolygon = Map1.TrackPolygon
            Map1.FlashShape MeasurePolygon, 1
            MsgBox "您所测量的多边形面积为" & Get2Decimal(CStr(MeasurePolygon.Area)) & "平方米", vbInformation, "测量结果"
            Set MeasurePolygon = Nothing
            End Select
            
        Case moCross
         '生成图形元素
         If barGraphics.Visible Then
              Select Case True
                Case barGraphics.Buttons("Add Text").Value = 1
                  Dim strGText As String
                  Dim ptGText As MapObjects2.Point
                  strGText = InputBox("请输入标识信息：")
                  Set ptGText = Map1.ToMapPoint(X, Y)
                  collGtextStrings.add strGText
                  collGtextPoints.add ptGText
                Case barGraphics.Buttons("Add Point").Value = 1
                  addtype = "point"
                  Dim ptGraphic As MapObjects2.Point
                  curtool = addpoint
                  Set ptGraphic = Map1.ToMapPoint(X, Y)
                  tl.AddEvent ptGraphic, 0
                  t2.AddEvent ptGraphic, 0
                  moPolygons.add ptGraphic
                Case barGraphics.Buttons("Add Line").Value = 1
                  addtype = "line"
                  Dim lnGraphic As MapObjects2.Line
                  curtool = addline
                  Set lnGraphic = Map1.TrackLine
                  tl.AddEvent lnGraphic, 1
                  t2.AddEvent lnGraphic, 1
                  moPolygons.add lnGraphic
                Case barGraphics.Buttons("Add Polygon").Value = 1
                  addtype = "polygon"
                  Dim polyGraphic As MapObjects2.Polygon
                  curtool = addpolygon
                  Set polyGraphic = Map1.TrackPolygon
                  tl.AddEvent polyGraphic, 2
                  t2.AddEvent polyGraphic, 2
                  moPolygons.add polyGraphic
            
            End Select
              Map1.TrackingLayer.Refresh True
              Map2.TrackingLayer.Refresh True
        End If
   Case Else: Exit Sub
   End Select
  
  End Sub

Public Function Get2Decimal(strNum As String) As String

Dim lSeek As Long
lSeek = InStrRev(strNum, ".")
If lSeek > 0 And Len(strNum) - lSeek > 2 Then
    Get2Decimal = Mid(strNum, 1, lSeek + 2)
Else
    Get2Decimal = strNum
End If

End Function '获得测量数值   保留小数点以后2位小数


Sub zoomin(Shift As Integer)                  '放大地图

Set trackRect = Map1.TrackRectangle()
Set newRect = Map1.extent
ow = trackRect.Width
If Shift = 0 Then
   newRect.ScaleRectangle (0.8)
Else
   newRect.ScaleRectangle (ow / Map1.extent.Width)
End If
Map1.extent = newRect

End Sub

Sub zoomout(Shift As Integer)                   '缩小地图

Set trackRect = Map1.TrackRectangle()
Set newRect = Map1.extent
ow = trackRect.Width
If Shift = 0 Then
   newRect.ScaleRectangle (1.2)
Else
   newRect.ScaleRectangle (Map1.extent.Width / ow)
End If
Map1.extent = newRect

End Sub

Private Sub toolbar_Click()

If toolbar.Checked = True Then
   toolbar.Checked = False
   Toolbar1.Visible = False
   Map1.Top = 0
   Map1.Height = Map1.Height + Toolbar1.Height
Else
    Toolbar1.Visible = True
    toolbar.Checked = True
    Map1.Top = Toolbar1.Height
     Map1.Height = Map1.Height - Toolbar1.Height
End If

End Sub                                    '工具栏控制

Private Sub statusbar_Click()

If statusbar.Checked = True Then
   statusbar.Checked = False
   StatusBar1.Visible = False
   Map1.Height = Map1.Height + StatusBar1.Height
   Frame1.Top = Frame1.Top + StatusBar1.Height
Else
    StatusBar1.Visible = True
    statusbar.Checked = True
    Map1.Height = Map1.Height - StatusBar1.Height
    Frame1.Top = Frame1.Top - StatusBar1.Height
End If

End Sub                                   '状态栏控制
Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
 
 Dim pt As New MapObjects2.Point
  Set pt = Map1.ToMapPoint(X, Y)
  StatusBar1.Panels(1).Text = " x= " & pt.X
  StatusBar1.Panels(2).Text = " y= " & pt.Y
  
End Sub                                         'map1坐标显示

Private Sub Form_Resize()

 Map1.Top = Toolbar1.Height
 Frame1.Top = Toolbar1.Height
End Sub                         '窗体改变尺寸,同时控件也改变尺寸