form2.frm

来自「采用VB和MO二次开发的全国经济地理信息系统 内含开发全过程的详细文档」· FRM 代码 · 共 989 行 · 第 1/2 页

  
  If strFileTitle <> "" Then
    
    With CommonDialog1
      sFileDirectory = Left$(.FileName, InStr(.FileName, .FileTitle) - 1)

    End With
        
    With dc
    .Database = sFileDirectory
        If .Connect Then
        sDataSetName = Mid(strFileTitle, 1, Len(strFileTitle) - 4)
        Set layer.GeoDataset = dc.FindGeoDataset(sDataSetName)
        Map1.Layers.Add layer
        Map2.Layers.Add layer
      Else
        MsgBox "Data Connection error #" & dc.ConnectError, vbExclamation
      End If
    End With
    
  End If
  
  Set dc = Nothing

  Set layer = Nothing
legend1.setMapSource Map1
legend1.LoadLegend True
Map1.Refresh
Map2.Refresh
End Sub

Private Sub Re_Click()
        Load FrmR
        FrmR.show
End Sub

Private Sub save_Click()                                   '保存
Dim strFileTitle As String, sDataSetName As String
  Dim sFileDirectory As String
  Dim dc As New MapObjects2.DataConnection
  Dim layer As New MapObjects2.MapLayer
  CommonDialog1.Filter = "Shapefiles (*.shp)|*.shp"
  CommonDialog1.ShowSave
End Sub
Private Sub print_Click()                                '打印
  On Error GoTo err1
  Printer.Print
  Map1.OutputMap Printer.hdc
  Printer.EndDoc
  MsgBox "打印完成。"
  Exit Sub
err1:
  MsgBox Err.Description + "，程序停止。"
  Unload Me
End Sub


Private Sub refreshScale()                                 '比例尺
 sbScaleBar1.MapExtent.MaxX = Map1.Extent.Right
 sbScaleBar1.MapExtent.MinX = Map1.Extent.Left
 sbScaleBar1.MapExtent.MaxY = Map1.Extent.Bottom
 sbScaleBar1.MapExtent.MinY = Map1.Extent.Top
   
 sbScaleBar1.PageExtent.MinX = Map1.Left / Screen.TwipsPerPixelX
 sbScaleBar1.PageExtent.MinY = Map1.Top / Screen.TwipsPerPixelY
 sbScaleBar1.PageExtent.MaxX = (Map1.Left + Map1.Width) / Screen.TwipsPerPixelX
 sbScaleBar1.PageExtent.MaxY = (Map1.Top + Map1.Height) / Screen.TwipsPerPixelY
 
 sbScaleBar1.Refresh
 StatusBar1.Panels(1).Text = "比例 1:" & Format$(sbScaleBar1.RFScale, "###,###,###,###,###")
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(4).Text = "大地坐标：" & " 经度：" & pt.x & " 纬度： " & pt.y    '状态栏
  
  If i = 5 Then
  Map1.MousePointer = moHotLink
  End If
End Sub


Private Sub SearchEc_Click()
        SeaEC = True
        i = 21
        Me.Map1.MousePointer = moIdentify
        
End Sub

Private Sub susea_Click()
        Frmsea.Caption = "选择查询的数据类型"
        Load Frmsea
        Frmsea.show
End Sub

Private Sub texing_Click()
 Formtuxing.show
 
End Sub




 Private Sub zoomin_Click()
  i = 1
  Map1.MousePointer = moZoomIn
  SeaEC = False
End Sub
Private Sub zoomout_Click()
  i = 2
 Map1.MousePointer = moZoomOut
 SeaEC = False
End Sub
Private Sub pan_Click()
 i = 3
 Map1.MousePointer = moPan

 ' Map1.MousePointer = 5
 SeaEC = False
End Sub
Private Sub show_Click()
 i = 4
 Set Map1.Extent = Map1.FullExtent
 Map1.MousePointer = moDefault
 SeaEC = False
End Sub


Private Sub liangce_Click()   '量测
 i = 5
 SeaEC = False
End Sub
Private Sub length_Click()
Map1.Refresh
 i = 6
 SeaEC = False
 Map1.MousePointer = 55
End Sub
Private Sub area_Click()
Map1.Refresh
 i = 7
 SeaEC = False
  Map1.MousePointer = 55
End Sub
Private Sub point_Click()
 i = 11
 Map1.MousePointer = 2
End Sub
Private Sub line_Click()
 i = 12
 Map1.MousePointer = 2
End Sub
Private Sub rectangle_Click()
 i = 13
 Map1.MousePointer = 2
End Sub
Private Sub cirle_Click()
 i = 14
 Map1.MousePointer = 2
End Sub
Private Sub poly_Click()
 i = 15
 Map1.MousePointer = 2                                                '点击查询某线段的长度
End Sub
Private Sub text_Click()
formtext.show                                   '写入文本
 i = 16

End Sub
Private Function trackShape() As Object                    '画多边形
  Dim poly As New MapObjects2.Polygon
  Dim evPoly As New MapObjects2.GeoEvent
  Set poly = Map1.TrackPolygon
  Set trackShape = poly
  Set evPoly = Map1.TrackingLayer.AddEvent(poly, 0)
     With Map1.TrackingLayer.Symbol(0)
      .SymbolType = moFillSymbol
      .Style = fill
      .color = color1
      .OutlineColor = color2
    End With
End Function

Private Function trackShape0() As Object                 ' 画线
    Dim line As New MapObjects2.line
    Dim evline As New MapObjects2.GeoEvent
    Set line = Map1.TrackLine
    Set trackShape0 = line
    Set evline = Map1.TrackingLayer.AddEvent(line, 0)
    With Map1.TrackingLayer.Symbol(0)
      .color = color1
      .SymbolType = moLineSymbol
      .Style = l
      .Size = size1
     ' .OutlineColor = color2
    End With
    End Function
Private Function trackShape1() As Object                '画矩形
  Dim poly As New MapObjects2.rectangle
  Dim evPoly As New MapObjects2.GeoEvent
  Set poly = Map1.TrackRectangle
  Set trackShape1 = poly
  Set evPoly = Map1.TrackingLayer.AddEvent(poly, 0)
   With Map1.TrackingLayer.Symbol(0)
      .SymbolType = moFillSymbol
      .Style = fill
      .color = color1
      .OutlineColor = color2
    End With
End Function

Private Function trackShape2() As Object                '画圆
  Dim poly As New MapObjects2.Ellipse
  Dim evPoly As New MapObjects2.GeoEvent
  Set poly = Map1.TrackCircle
  Set trackShape2 = poly
  Set evPoly = Map1.TrackingLayer.AddEvent(poly, 0)
     With Map1.TrackingLayer.Symbol(0)
      .SymbolType = moFillSymbol
      .Style = fill
      .color = color1
      .OutlineColor = color2
    End With
End Function
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim r As MapObjects2.rectangle
     If i = 1 Then
                    Map1.Extent = Map1.TrackRectangle
                    Set r = Map1.Extent
                     r.ScaleRectangle (0.5)
                       Set Map1.Extent = r
     ElseIf i = 2 Then
                     Set r = Map1.Extent
                     r.ScaleRectangle (4)
                       Set Map1.Extent = r
     ElseIf i = 3 Then
                    Map1.pan
     ElseIf i = 4 Then
                    Set r = Map1.FullExtent
                    Set Map1.Extent = r
     ElseIf i = 5 Then                             '量测
     Set moline1 = Map1.TrackLine
     Dim dx As Double
     dx = 40075.7 / 360
      Map1.TrackingLayer.Refresh True
      MsgBox "地图距离;" + Format(moline1.length * dx & "公里", "#")
      StatusBar1.Panels(2).Text = "地图距离;" + Format(moline1.length * dx & "公里", "#")
      StatusBar1.Panels(3).Text = "控件距离;" + Format(Map1.FromMapDistance(moline1.length), "#.00")
      
     End If
     
       If i = 6 Then                            '查询某线段的长度
     Dim P2 As MapObjects2.point
     Dim Shp2 As MapObjects2.line
     Dim Rleng As Single
     Const Rx = 30
     Set P2 = Map1.ToMapPoint(x, y)
     Set Recs = Map1.Layers(a).SearchByDistance(P2, Map1.ToMapDistance(30), "")
     If Recs.EOF Then
      StatusBar1.Panels(5) = "没有找到对象。"
     Else
      Set Shp2 = Recs.Fields("Shape").Value
      Map1.FlashShape Shp2, 2
      Rleng = Format(Shp2.length * Rx, "0.00")
   StatusBar1.Panels(5) = "找到" & Recs.Fields("NAME").Value & "，长度为" & Rleng & "公里。"
    End If
     'Map1.Refresh
    End If
                    
     If i = 7 Then                             '点击查询地图的面积
     Dim Pl As MapObjects2.point
     Dim Shp1 As MapObjects2.Polygon
     Dim area As Single
     Const Ak = 10000
     Set Pl = Map1.ToMapPoint(x, y)
     Set Recs = Map1.Layers(a).SearchByDistance(Pl, Map1.ToMapDistance(30), "")
     If Recs.EOF Then
     StatusBar1.Panels(5).Text = "没有找到对象。"
     Else
     Set Shp1 = Recs.Fields("Shape").Value
     Map1.FlashShape Shp1, 2
     area = Format(Shp1.area * Ak, "0.00")
     StatusBar1.Panels(5).Text = "找到" & Recs.Fields("NAME").Value & "，面积为" & area & "平方公里。"
     End If
     'Map1.Refresh
     End If
     
     
     If i = 11 Then
     Set pt = Map1.ToMapPoint(x, y)             '画点
     Map1.TrackingLayer.Symbol(0).color = color1
     Map1.TrackingLayer.Symbol(0).CharacterIndex = 89
     Map1.TrackingLayer.AddEvent pt, 0
     End If
    If i = 12 Then
 
       Set Shp = trackShape0                  '画线
    End If

    If i = 13 Then                            '画矩形
      Set Shp = trackShape1
    End If
    If i = 14 Then                             '画圆
     Set Shp = trackShape2
    End If
    If i = 15 Then                            '画多边形
     Set Shp = trackShape
    End If
    If i = 16 Then
     Set P1 = Map1.ToMapPoint(x, y)         '为写文本指定一点
     Map1.Refresh
    End If
    If i = 21 Then                          '经济数据查询
       Unload FrmSearchEc
      
       Set pt = Map1.ToMapPoint(x, y)
       Set SeaEcRecs = Map1.Layers(a).SearchShape(pt, moPointInPolygon, "")
        If SeaEcRecs.Count <> 0 Then
            Load FrmSearchEc
            FrmSearchEc.show
            Map1.FlashShape SeaEcRecs("shape").Value, 2
        End If
    End If
End Sub


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          '使Map2和Map1联动；
  End If
  Call refreshScale
    

  
End Sub
Private Sub Map1_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
If Not P1 Is Nothing Then
    Map1.DrawText tx, P1, TextSym             '写文本
  End If
  
 If Not moline1 Is Nothing Then               '已测量线段后显示的样式
 Dim sym3 As New MapObjects2.Symbol
  sym3.Style = moDashLine
  sym3.color = moRed
  Map1.DrawShape moline1, sym3
 End If
  
Dim Sym1 As New MapObjects2.Symbol         '选中某一区域后显示黄色
  If Not Recs Is Nothing Then
    Sym1.color = moBlue
    Map1.DrawShape Recs, Sym1
  End If
End Sub
Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  '将点击转换为Map2上的点对象；
  Dim p As point
  Set p = Map2.ToMapPoint(x, y)
  
  '如果点击发生在方框内，开始拖动；
  If Map1.Extent.IsPointIn(p) Then
    Set g_feedback = New DragFeedback
    g_feedback.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 g_feedback Is Nothing Then
    g_feedback.DragMove x, y
  End If
End Sub

'拖动完成，并在Map1中显示新位置；
Private Sub Map2_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  If Not g_feedback Is Nothing Then
    Map1.Extent = g_feedback.DragFinish(x, y)
    Set g_feedback = Nothing
  End If
End Sub
'在Map2上画红色指示框；
Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
  Dim sym As New Symbol
  sym.OutlineColor = moRed
  sym.Size = 2
  sym.Style = moTransparentFill
  Map2.DrawShape Map1.Extent, sym
End Sub



Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)   '拖把
  If Button.index = 1 Then
   open_Click
  ElseIf Button.index = 2 Then
   save_Click
  ElseIf Button.index = 3 Then
   print_Click
  ElseIf Toolbar1.Buttons(4).Value = 1 Then
   zoomin_Click

  ElseIf Toolbar1.Buttons(5).Value = 1 Then
    zoomout_Click
  ElseIf Toolbar1.Buttons(6).Value = 1 Then
    pan_Click
   
  ElseIf Toolbar1.Buttons(7).Value = 1 Then
    show_Click
  ElseIf Toolbar1.Buttons(8).Value = 1 Then
    liangce_Click
  
  ElseIf Toolbar1.Buttons.Item(10).Value = 1 Then
  formtext.show                                   '写入文本
  
End If
End Sub

'设置
Private Sub status_Click()
If Status.Checked Then
  StatusBar1.Visible = 0
  Status.Checked = 0
Else
 StatusBar1.Visible = 1
 Status.Checked = 1
End If
End Sub

Private Sub toobar_Click()
If toobar.Checked Then
  Toolbar1.Visible = 0
  toobar.Checked = 0
Else
    Toolbar1.Visible = 1
  toobar.Checked = 1
End If

End Sub
'帮助
Private Sub help_Click()

End Sub
Sub DrawLayer()                                          '初始化
  Dim dc As New DataConnection
  Dim layer As MapLayer
  dc.Database = App.Path
  If Not dc.Connect Then
    MsgBox "在指定的文件夹下没找到图层数据文件！"
    End
  End If
  
  Set layer = New MapLayer
  Set layer.GeoDataset = dc.FindGeoDataset("省界prj")
  layer.Symbol.color = moYellow
  Map1.Layers.Add layer
  Map2.Layers.Add layer
  
  Set layer = New MapLayer
  Set layer.GeoDataset = dc.FindGeoDataset("公路prj")
  layer.Symbol.color = moRed
  Map1.Layers.Add layer
  Map2.Layers.Add layer
  
   Set layer = New MapLayer
  Set layer.GeoDataset = dc.FindGeoDataset("省界线prj")
  layer.Symbol.color = moBrown
  Map1.Layers.Add layer
  Map2.Layers.Add layer
  
  Set layer = New MapLayer
  Set layer.GeoDataset = dc.FindGeoDataset("河流prj")
  layer.Symbol.color = moGreen
  Map1.Layers.Add layer
  Map2.Layers.Add layer
  
  Set layer = New MapLayer
  Set layer.GeoDataset = dc.FindGeoDataset("铁路prj")
  layer.Symbol.color = moBlue
  Map1.Layers.Add layer
  Map2.Layers.Add layer
  
  Set layer = New MapLayer
  Set layer.GeoDataset = dc.FindGeoDataset("主要城市")
  layer.Symbol.color = moPurple
  Map1.Layers.Add layer
  Map2.Layers.Add layer
  
  legend1.setMapSource Map1
  legend1.LoadLegend True
  Map1.Refresh

End Sub