form1.frm

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

  End If
End Sub



'"搜索距离"文本框按键事件响应代码
Private Sub Text3_KeyPress(KeyAscii As Integer)

End Sub


Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
  Case "cmdpan"
    strStatus = "平移"
    '设置鼠标指针
    Map1.MousePointer = moPan
  Case "cmdzoomout"
     strStatus = "缩小"
    '设置鼠标指针
    Map1.MousePointer = moZoomOut
  Case "cmdzoomin"
    '标志放大状态
    strStatus = "放大"
    '设置鼠标指针
    Map1.MousePointer = moZoomIn
  Case "cmdglobe"
   '设置Map1的当前显示范围是全图
    Set Map1.extent = Map1.fullextent
    Map1.MousePointer = moDefault
  Case "openfile"
    openfile
'点图形查属性
  Case "search"
     strStatus = "查询"
   Map1.MousePointer = moIdentify
  Case "print"
    On Error GoTo err1
    Printer.Print
    Map1.OutputMap Printer.hDC
    Printer.EndDoc
    MsgBox "打印完成。"
    Exit Sub
err1:
    MsgBox Err.Description + "，程序停止。"
 '测直线距离
  Case "dianxuan"
    strStatus = "点选"
    Map1.MousePointer = moPencil
  End Select
End Sub


'求并
Private Sub union_Click()
 If Not poly1 Is Nothing Then
    Set poly = poly1.union(poly2)
    Map1.TrackingLayer.Refresh True
 End If
End Sub


Private Sub vehicleinfo_Click()
  Unload Me
  Me.Hide
  busmanage.Show
End Sub


'求异或
Private Sub Xor_Click()
If Not poly1 Is Nothing Then
   Set poly = poly1.Xor(poly2)
   Map1.TrackingLayer.Refresh True
End If
End Sub


'根据点击的坐标选择对象
'最大化屏幕显示
Private Sub extent_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

Frame1.Visible = False
Frame2.Visible = False
StatusBar1.Visible = False
exitglode.Visible = True
cmdMagnifier.Visible = False
cmdOverview.Visible = False
Text1.Visible = False
End Sub


'漫游
Private Sub pan_Click()
     strStatus = "平移"
    '设置鼠标指针
    Map1.MousePointer = moPan
End Sub

'还原
Private Sub fullextent_Click()
  Set Map1.extent = Map1.fullextent
End Sub


'放大
Private Sub zoomin_Click()
  Dim r As MapObjects2.Rectangle
  Set r = Map1.extent
  r.ScaleRectangle 0.67
  Map1.extent = r
End Sub


'自由放大
Private Sub zoominfree_Click()
'标志放大状态
    strStatus = "放大"
    '设置鼠标指针
    Map1.MousePointer = moZoomIn
End Sub


'缩小
Private Sub zoomout_Click()
 Dim r As MapObjects2.Rectangle
 Set r = Map1.extent
 r.ScaleRectangle 1.5
 Map1.extent = r
End Sub


'加载图层
Private Sub open_Click()
   openfile
End Sub


Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
    Dim sym1 As New MapObjects2.Symbol
Dim sym2 As New MapObjects2.Symbol

     Dim sym  As New MapObjects2.Symbol
   '画两点
  
  If strStatus = "点选" Then
    If Not oPoint1 Is Nothing Then
      sym1.SymbolType = moPointSymbol
      sym1.color = moRed
      sym1.Size = 5
      sym1.style = 0
      Map1.drawshape oPoint1, sym1
    Map1.Refresh
    End If
    If Not oPoint2 Is Nothing Then
      sym2.SymbolType = moPointSymbol
      sym2.color = moBlue
      sym2.Size = 5
      sym2.style = 0
      Map1.drawshape oPoint2, sym2
      Map1.Refresh
    End If
  End If
  
  '画多边形
  If strStatus = "选择多边形" Then
     sym.color = moRed
     sym1.color = moGreen
     sym2.color = moCyan
    
  If Not poly Is Nothing Then
    Set poly1 = Nothing
    Set poly2 = Nothing
    Map1.drawshape poly, sym
  Else
    If Not poly1 Is Nothing Then
      Map1.drawshape poly1, sym1
    End If
    If Not poly2 Is Nothing Then
      Map1.drawshape poly2, sym2
    End If
  End If

     
  If Not gline Is Nothing Then
    Map1.drawshape gline, sym1
  End If
  If Not buffline Is Nothing Then
    Map1.drawshape buffline, sym2
  End If
  
  
  If strStatus = "选择分析道路" Then
     With sym1
       .SymbolType = moLineSymbol
       .color = moRed
       .Size = 3
     End With
     With sym2
       .SymbolType = moFillSymbol
       .style = moGrayFill
       .color = moBlue
       .OutlineColor = moBlue
     End With
     End If
  
  End If
   If Not gline Is Nothing Then
    Map1.drawshape gline, sym1
  End If
  If Not buffline Is Nothing Then
    Map1.drawshape buffline, sym2
  End If
    
    If strStatus = "移动线源分析" Then
    
     With sym
         .color = moRed
    End With
     
     If Not buffline Is Nothing Then
        Map1.drawshape buffline, sym
        
     End If
  End If
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  
  
  Dim temExtent As MapObjects2.Rectangle
   Select Case strStatus
   Case "放大"
        Set temExtent = Map1.TrackRectangle
        If Not temExtent Is Nothing Then
           Map1.extent = temExtent
        End If
    Case "平移"
        '进入平移漫游状态,跟踪鼠标动作
        'MsgBox "jj"
        Map1.pan
    
    Case "缩小"
        '跟踪用户输入的矩形显示范围
        Set temExtent = Map1.extent
        Dim mapwidth As Long
        mapwidth = Map1.TrackRectangle.Width
         If (mapwidth > 0) Then
         temExtent.ScaleRectangle Map1.extent.Width / mapwidth
         Else
        temExtent.ScaleRectangle 1.2
        End If
        Set Map1.extent = temExtent
     Case "查询"
     '点击弹出属性框
     Dim field, fld As MapObjects2.field
     Dim pt As MapObjects2.Point
     Dim newitem As Object
     Dim layer As MapObjects2.MapLayer
     Set layer = New MapLayer
     Const SEARCHTOLPIXELS = 3
     Dim thetol As Double
     thetol = Map1.ToMapDistance(SEARCHTOLPIXELS * Screen.TwipsPerPixelX)
     For Each layer In Map1.Layers
   '  If layer.Visible = True Or layer.LayerType = moMapLayer Then
     Set pt = Map1.ToMapPoint(X, Y)
     Set rec = layer.SearchByDistance(pt, thetol, "")
     If Not rec.EOF Then
        frmproperty.ListView1.ListItems.clear
        For Each fld In rec.Fields
          Set newitem = frmproperty.ListView1.ListItems.Add
          newitem.Text = fld.name
          newitem.SubItems(1) = fld.ValueAsString
        Next fld
        Load frmproperty
        frmproperty.Show
      End If
      If Not rec.EOF Then
      Map1.FlashShape rec.Fields("Shape").Value, 3
      End If
      Next
      Map1.Refresh
      Case "选择分析道路"
      Set p = Map1.ToMapPoint(X, Y)
       Set recs = Map1.Layers(0).SearchByDistance(p, Map1.ToMapDistance(30), " ")
    If recs.EOF Then
       MsgBox "没找到线段"
    Else
       Set gline = recs.Fields("shape").Value
       Map1.FlashShape gline, 2
    End If
    Case "选择多边形"
    If poly1 Is Nothing Then
         Const rx = 30
         Set p = Map1.ToMapPoint(X, Y)
         Set recs = Map1.Layers(0).SearchByDistance(p, Map1.ToMapDistance(30), "")
         '待解决问题2LAKES
         Map1.Refresh
      If recs.EOF Then
         MsgBox "没找到第一个多边形"
      Else
         Set poly1 = recs.Fields("shape").Value
         Map1.FlashShape poly1, 2
      End If
     Else
          Set p = Map1.ToMapPoint(X, Y)
          Set recs2 = Map1.Layers(0).SearchByDistance(p, Map1.ToMapDistance(30), "")
          '待解决问题3LAKES
          Map1.Refresh
      If recs2.EOF Then
          MsgBox "没找到第二个多边形"
      Else
          Set poly2 = recs2.Fields("shape").Value
          Map1.FlashShape poly2, 2
      End If
     End If
     Case "移动线源分析"
     Call calculate2(X, Y)
     Case "点选"
     Dim fDist As Double
     Dim h As Single
     If oPoint1 Is Nothing Then
       Set oPoint1 = Map1.ToMapPoint(X, Y)
       Exit Sub
     Else
       Set oPoint2 = Map1.ToMapPoint(X, Y)
       fDist = oPoint2.DistanceTo(oPoint1)
       Map1.TrackingLayer.Refresh True
       MsgBox "距离＝" & Format(fDist, "fixed")
    
     End If
    Set oPoint1 = Nothing
      End Select
 
End Sub

Sub DrawSelection(recs As MapObjects2.Recordset, color)
  ' draw the features of a RecordSet
  Dim sym As New MapObjects2.Symbol
  sym.SymbolType = moFillSymbol
  sym.style = moSolidFill
  sym.color = color
  If Not recs Is Nothing Then
    Map1.drawshape recs, sym
  End If
End Sub

'使map1和map2连动
Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hDC As stdole.OLE_HANDLE)
  If Not polygon1 Is Nothing Then
  Call DrawSelection(recs1, moBlack)
  End If
  If Not polygon2 Is Nothing Then
  Call DrawSelection(recs4, moBlack)
  End If
  
  If Not polygon3 Is Nothing Then
  Call DrawSelection(recs3, moBlack)
  End If
  
  refreshscale
  
  If Index = 0 Then
    Map2.TrackingLayer.Refresh True
  End If
  Dim sym As New MapObjects2.Symbol
Dim sym1 As New MapObjects2.Symbol
With sym
    .SymbolType = moPointSymbol
    .style = 2
    .color = moRed
    .Size = 5
End With
With sym1
    .SymbolType = moPointSymbol
    .style = 2
    .color = moBlue
    .Size = 5
End With

Select Case strStatus

Case "查询"  '属性查询
     If Not rec.EOF Then
        Map1.drawshape rec.Fields("Shape").Value, sym
        frmproperty.Label1.Caption = "找到：" & rec.Count & "个对象"
     End If
     End Select
      '判断是否有符合条件的地理对象

'sql查询重绘代码开始
 If Not SelectedFeatures Is Nothing Then
    '建立Symbol对象以决定地理对象的显示方式
    Dim NewSym As New MapObjects2.Symbol
    NewSym.color = moBlue
    '重绘符合条件的地理对象
    Map1.drawshape SelectedFeatures, NewSym
  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 refreshscale()
ScaleBar1.MapExtent.MaxX = Map1.extent.Right
ScaleBar1.MapExtent.MinX = Map1.extent.Left
ScaleBar1.MapExtent.MaxY = Map1.extent.Bottom
ScaleBar1.MapExtent.MinY = Map1.extent.Top
ScaleBar1.PageExtent.MinX = Map1.Left / Screen.TwipsPerPixelX
ScaleBar1.PageExtent.MinY = Map1.Top / Screen.TwipsPerPixelY
ScaleBar1.PageExtent.MaxX = (Map1.Left + Map1.Width) / Screen.TwipsPerPixelX
ScaleBar1.PageExtent.MaxY = (Map1.Top + Map1.Height) / Screen.TwipsPerPixelY
ScaleBar1.Refresh
StatusBar1.Panels(4).Text = "比例   1 ： " & Format$(ScaleBar1.RFScale, "###,###,###,###")
End Sub