form1.frm

这个是利用地理信息系统组件MO做的武汉道路污染源强的分析系统。

         End
         Begin VB.Menu nearestroad 
            Caption         =   "最短路径Dijkstra算法"
         End
      End
   End
   Begin VB.Menu statistics 
      Caption         =   "统计分析"
      Begin VB.Menu thematic 
         Caption         =   "专题图输出"
      End
      Begin VB.Menu cartogram 
         Caption         =   "统计图输出"
      End
   End
   Begin VB.Menu help 
      Caption         =   "帮 助(H)"
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim p As MapObjects2.Point
Dim oPoint1 As MapObjects2.Point
Dim oPoint2 As MapObjects2.Point
Dim flag As Single
Dim case2 As Single
Dim poly As MapObjects2.Polygon
Dim poly1 As MapObjects2.Polygon
Dim poly2 As MapObjects2.Polygon
Dim gline As New MapObjects2.Line
Dim polygon1 As MapObjects2.Polygon
Dim polygon2 As MapObjects2.Polygon
Dim polygon3 As MapObjects2.Polygon
Dim buffline As New MapObjects2.Polygon
Dim strStatus As String
Dim bdist As Single
Dim rec As MapObjects2.Recordset
Dim recs  As MapObjects2.Recordset
Dim recs2 As MapObjects2.Recordset
Dim recs1  As MapObjects2.Recordset
Dim recs4  As MapObjects2.Recordset
Dim recs3  As MapObjects2.Recordset
Dim SelectedFeatures As MapObjects2.Recordset

Dim g_selectedFeatures As MapObjects2.Recordset
Dim g_searchSet As MapObjects2.Recordset

Dim sym As MapObjects2.Symbol
Dim g_searchShape As Object
Dim g_selectedBounds As MapObjects2.Rectangle
Dim g_searchBounds As MapObjects2.Rectangle



Sub drawshape(shape As Object, color, style)
  '显示图形
  If Not shape Is Nothing Then
    Dim sym As New Symbol
    sym.color = color
    If style = moTransparentFill Then sym.OutlineColor = color
    sym.style = style
    Map1.drawshape shape, sym
  End If
End Sub



Sub openfile()
  Dim dc As New DataConnection
  Dim gs As GeoDataset
  Dim name As String
  Dim layer As MapObjects2.MapLayer
  CommonDialog1.Filter = "ESRI Shapefiles(*.shp)|*.shp"
  CommonDialog1.ShowOpen
If Len(CommonDialog1.FileName) = 0 Then Exit Sub
   dc.Database = CurDir
   If Not dc.Connect Then Exit Sub
   name = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4)
   Set gs = dc.FindGeoDataset(name)
If gs Is Nothing Then Exit Sub

   Set layer = New MapLayer
   layer.GeoDataset = gs
   Map1.Layers.Add layer
 
 legend1.LoadLegend
 
 Map1.Refresh
 Map2.Layers.Add layer
 Map2.Refresh
End Sub


Sub bufferradius()
Dim msg1 As String
Dim msg2 As String
msg1 = "请输入缓冲半径"
msg2 = "缓冲半径选择窗口"
bdist = InputBox(msg1, msg2)

End Sub


Sub calculate2(X As Single, Y As Single)
Dim b1, b2, b3, b4, b5  As Single
Dim a1  As Integer
Dim a2  As Integer
Dim a3  As Integer
Dim a4  As Integer
Dim a5  As Integer
Dim bdist As Long
Dim c As Single
Dim sym1 As New MapObjects2.Symbol
Dim sym2 As New MapObjects2.Symbol
'Dim sym3 As New MapObjects2.Symbol
  With sym1
       .SymbolType = moLineSymbol
       .color = moRed
       .Size = 3
     End With
     With sym2
       .SymbolType = moFillSymbol
       .style = moGrayFill
       .color = moBlue
       .OutlineColor = moBlue
     End With


 Set p = Map1.ToMapPoint(X, Y)
 Set recs = Map1.Layers("wuran").SearchByDistance(p, Map1.ToMapDistance(30), " ")
  If recs.EOF Then
       MsgBox "没找到线段或者线段不符合要求"
    Else
       Set gline = recs.Fields("shape").Value
       Map1.FlashShape gline, 2
  End If
  If Not recs.EOF Then
 a1 = recs.Fields("轻车流量").Value
 a2 = recs.Fields("中车流量").Value
 a3 = recs.Fields("重车流量").Value
 a4 = recs.Fields("公车流量").Value
 a5 = recs.Fields("出车流量").Value
 b1 = recs.Fields("轻排放因子").Value
 b2 = recs.Fields("中排放因子").Value
 b3 = recs.Fields("重排放因子").Value
 b4 = recs.Fields("公排放因子").Value
 b5 = recs.Fields("出排放因子").Value
 c = recs.Fields("路长").Value

bdist = c * (a1 * b1 + a2 * b2 + a3 * b3 + a4 * b4 + a5 * b5)
Set buffline = gline.Buffer(bdist / 4000)
Map1.FlashShape buffline, 3
Map1.Refresh
MsgBox "源强= " & bdist


Set recs1 = Map1.Layers("Government").SearchShape(buffline, moEdgeTouchOrAreaIntersect, "")
Set recs4 = Map1.Layers("School").SearchShape(buffline, moEdgeTouchOrAreaIntersect, "")
Set recs3 = Map1.Layers("resident").SearchShape(buffline, moEdgeTouchOrAreaIntersect, "")

MsgBox "一共找到 " & recs1.Count + recs4.Count + recs3.Count & "个对象" & vbCrLf & "  " & recs1.Fields("名称").Value & vbCrLf & "  " & recs4.Fields("名称").Value & vbCrLf & "  " & recs3.Fields("名称").Value & vbCrLf & "建议搬迁"

Set polygon1 = recs1.Fields("shape").Value
Set polygon2 = recs4.Fields("shape").Value
Set polygon3 = recs3.Fields("shape").Value

End If
Map1.FlashShape buffline, 10
Set buffline = Nothing
Map1.Layers("Government").Visible = False
Map1.Layers("School").Visible = False
Map1.Layers("resident").Visible = False
Map1.Layers("wuran").Visible = False
Map1.Refresh


End Sub

Private Sub automobile_Click()
Map1.MousePointer = moDefault
strStatus = "移动线源分析"
End Sub

Private Sub buffer2_Click()

If Not gline Is Nothing Then
    Set buffline = gline.Buffer(bdist, Map1.fullextent)
    Map1.TrackingLayer.Refresh True
 End If
End Sub



Private Sub clear_Click()
   Map1.Layers.clear
   Map2.Layers.clear
End Sub

Private Sub clientinfo_Click()
Unload Me
Me.Hide
Form5.Show
End Sub

Private Sub cmdMagnifier_Click()
Dim overVis As Boolean

' -- 如果magnifier已经打开，并且初始化
If Not frmMagnifier.Visible Then
  overVis = frmOverview.Visible
  If overVis Then
    frmOverview.ZOrder vbSendToBack
    Form1.Refresh
  End If
  frmMagnifier.Left = Form1.Left + 600
  frmMagnifier.Top = Form1.Top + 1200
  frmMagnifier.SetFormAndMap Me, Map1
  frmMagnifier.Show
  If overVis Then
    frmOverview.StayOnTop True
  End If
End If
End Sub

Private Sub cmdOverview_Click()
If Not frmOverview.Visible Then
  frmOverview.Left = Form1.Left + 600
  frmOverview.Top = Form1.Top + 1200
  frmOverview.AddLayer Map1.Layers("States")
  '增加小窗口图层
  frmOverview.AddMap Map1
  frmOverview.SetFullExtent Map1.fullextent
  frmOverview.Show
  End If
End Sub


Private Sub end_Click()
End
End Sub



Private Sub exitglode_Click()
'设置FORM
With Me
    .Height = 600 * 15
    .Width = 800 * 15
    .Left = (Screen.Width - .Width) / 2
    .Top = (Screen.Width - .Width) / 2
End With

'设置MAP
With Map1
    .Height = 6495
    .Width = 7935
    .Top = 1080
    .Left = 2880
End With
Frame1.Visible = True
Frame2.Visible = True
StatusBar1.Visible = True
exitglode.Visible = False
cmdMagnifier.Visible = True
cmdOverview.Visible = True
Text1.Visible = True

End Sub

Private Sub Command2_Click()

With Me
    .Height = Screen.Height
    .Width = Screen.Width
    .Left = (Screen.Width - .Width) / 2
    .Top = (Screen.Height - .Height) / 2
    .Caption = "最大化屏幕"
End With

'设置MAP
 With Map1
    .Height = Me.Height - 1200
    .Width = Me.Width - 200
    .Top = 50
    .Left = 50
End With

End Sub

Private Sub Form_Load()
     
   Text1.Text = ""   '初始化SQL查询框
   Set SelectedFeatures = Nothing
   
   legend1.setMapSource Map1
   legend1.LoadLegend True
   legend1.ShowAllLegend
   legend1.Active(0) = True
   exitglode.Visible = False
   
   Set g_selectedFeatures = Nothing
  Set g_searchShape = Nothing
  Set g_searchSet = Nothing
  Set g_selectedBounds = Nothing
  Set g_searchBounds = Nothing
  
End Sub

Private Sub legend1_AfterSetLayerVisible(Index As Integer, isVisible As Boolean)
Map1.Refresh
Map2.Refresh
End Sub



Private Sub linebuffer_Click()
 bufferradius
 '调用bufferradius过程
 If Not gline Is Nothing Then
    Set buffline = gline.Buffer(bdist, Map1.fullextent)
    Map1.TrackingLayer.Refresh True
 End If
End Sub

Private Sub length1_Click()
strStatus = "点选"
End Sub

Private Sub length2_Click()
flag = 6
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(2).Text = "x=" & pt.X
  StatusBar1.Panels(3).Text = "y=" & pt.Y
End Sub


Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
 Dim curRectangle As MapObjects2.Rectangle
 Dim pt As New MapObjects2.Point
 Set curRectangle = Map2.TrackRectangle
 Set Map1.extent = curRectangle
 Set pt = Map2.ToMapPoint(X, Y)
 Map1.CenterAt pt.X, pt.Y
End Sub


Private Sub point_Click()
strStatus = "点选"

End Sub


Private Sub pointselect_Click()
  strStatus = "查询"
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 save_Click()
'"导出"按钮鼠标单击事件响应代码

  '获取文件名
  CommonDialog1.Filter = "ESRI Shapefiles (*.shp)|*.shp"
  CommonDialog1.DefaultExt = ".shp"
  CommonDialog1.ShowSave
  If Len(CommonDialog1.FileName) = 0 Then Exit Sub
  
  Screen.MousePointer = vbHourglass
  '将编辑图层中的数据导出为Shape文件
  Map1.Layers(0).ExportToShapefile CommonDialog1.FileName
  Screen.MousePointer = vbDefault

End Sub


Private Sub select1_Click()
strStatus = "选择分析道路"
End Sub


'选择
Private Sub select2_Click()
strStatus = "选择多边形"
End Sub


'求差
Private Sub difference_Click()
 If Not poly1 Is Nothing Then
    Set poly = poly1.difference(poly2)
    Map1.TrackingLayer.Refresh True
 End If
End Sub

'求交
Private Sub intersect_Click()
If Not poly1 Is Nothing Then
    Set poly = poly1.intersect(poly2)
    Map1.TrackingLayer.Refresh True
End If
End Sub


Private Sub simple_Click()
Load checkgraphy
checkgraphy.Show
End Sub

Private Sub Text1_Change()
  If Text1.Text = "" Then
    '查询条件为空
    Set SelectedFeatures = Nothing
  Else
    '获取Country图层
    Dim ly As MapObjects2.MapLayer
    Set ly = Map1.Layers(0)
    '使用SearchExpression方法获取符合TextBox中查询语句的地理对象
    Set SelectedFeatures = ly.SearchExpression(Text1.Text)
    Map1.Refresh