form1.frm

VB+OBJECT编写

  End If
  Set recSelection = Map1.Layers(0).SearchExpression(strExp)
    Map1.Refresh
  End Sub

Private Sub Command1_Click()
Dim s As New MapObjects2.MapLayer
If Map1.Layers.Count < 1 Then
MsgBox "没有图层需要隐藏"
Exit Sub
Else
Set s = Map1.Layers(0)
s.Visible = False
Map1.Refresh
End If
End Sub
Private Sub Command2_Click()
If Map1.Layers.Count < 1 Then
MsgBox "没有图层可以显示"
Exit Sub
Else
Map1.Layers.Item(0).Visible = True
Map1.Refresh
End If
End Sub
Private Sub Command3_Click()
If Map1.Layers.Count > 1 Then
    If Map1.Layers(0).Visible = False Then
        MsgBox "没有图层或者只有一个图层"
        Exit Sub
    End If
    If Command3.Caption = "图层置顶" Then
        Command3.Caption = "图层下移"
        Map1.Layers.MoveToTop 1
        Map1.Refresh
    ElseIf Command3.Caption = "图层下移" Then
        Command3.Caption = "图层置顶"
        Map1.Layers.MoveToBottom 0
        Map1.Refresh
    End If
Else
    MsgBox "没有图层或者只有一个图层。"
End If
End Sub

Private Sub Command4_Click()
If Map1.Layers.Count = 0 Then
legend1.Visible = False
MsgBox "没有图层"
Else
If legend1.Visible = True Then
legend1.Visible = False
Command4.Caption = "显示Map控件"
Else
legend1.Visible = True
Command4.Caption = "隐藏Map控件"
End If
End If
End Sub

Private Sub Command7_Click()
If Command7.Caption = "查询" Then
Command7.Caption = "退出查询"
Command1.Visible = False
Command2.Visible = False
Command3.Visible = False
Command4.Visible = False
Command5.Visible = False
Command6.Visible = False
Label1.Visible = True
Combo1.Visible = True
Combo2.Visible = True
Combo3.Visible = True
Else
Command7.Caption = "查询"
Command1.Visible = True
Command2.Visible = True
Command3.Visible = True
Command4.Visible = True
Command5.Visible = True
Command6.Visible = True
Label1.Visible = False
Combo1.Visible = False
Combo2.Visible = False
Combo3.Visible = False
End If
Map1.Layers.Clear
Dim lyr As New MapObjects2.MapLayer
Dim dc As New MapObjects2.DataConnection
Dim gds As New MapObjects2.GeoDataset
dc.Database = App.Path + "\.\data"
Set gds = dc.FindGeoDataset("bou2_4p")
Set lyr.GeoDataset = gds
Map1.Layers.add lyr
Map1.Layers("bou2_4p").name = "行政区"
With lyr.Symbol
.Color = moDarkGreen
End With
Combo1.Clear
Combo2.Clear
Combo3.Clear
  With Combo1
    Dim fldLyr As MapObjects2.Field
    For Each fldLyr In Map1.Layers(0).Records.Fields
      If fldLyr.Type < 20 Then
        .AddItem fldLyr.name
      End If
    Next fldLyr
    .ListIndex = 0
  End With
    With Combo2
      .AddItem "="
    .AddItem "<"
    .AddItem ">"
    .AddItem "<="
    .AddItem ">="
    .AddItem "Like"
    .ListIndex = 0
  End With
  Call ListValues
    Set g_symSelection = New MapObjects2.Symbol
  With g_symSelection
    .SymbolType = Map1.Layers(0).Symbol.SymbolType
    .Color = moYellow
  End With
End Sub
Private Sub ListValues()
  If Len(Combo1.List(Combo1.ListIndex)) > 0 Then
    Dim recLyr As MapObjects2.Recordset
    Set recLyr = Map1.Layers(0).Records
    Dim strName As String
    strName = Combo1.List(Combo1.ListIndex)
    Combo3.Clear
    Do While Not recLyr.EOF
      Combo3.AddItem recLyr.Fields(strName).ValueAsString
      recLyr.MoveNext
    Loop
  End If
Combo3.Text = "<选择字段值>"
End Sub
Private Sub Command5_Click()
If Map1.Layers.Count < 1 Then
legend1.Visible = False
List1.Visible = False
MsgBox "没有图层"
Else
Map1.Layers.Remove 0
End If
End Sub
Private Sub Command6_Click()
List1.Visible = False
If Map1.Layers.Count < 1 Then
MsgBox "没有图层"
Else
Map1.Layers.Clear
legend1.Visible = False
End If
End Sub

Private Sub exit_Click()
End
End Sub

Private Sub Form_Load()
Dim dc As New DataConnection
dc.Database = App.Path & "\data"
If Not dc.Connect Then End
Dim Layer As MapLayer
Set Layer = New MapLayer
Set Layer.GeoDataset = dc.FindGeoDataset("bou2_4p")
Layer.Symbol.Color = moPaleYellow
Map1.Layers.add Layer
Set Layer = New MapLayer
Set Layer.GeoDataset = dc.FindGeoDataset("river5_polyline")
Layer.Symbol.Color = moBlue
Map1.Layers.add Layer
Set Layer = New MapLayer
Set Layer.GeoDataset = dc.FindGeoDataset("roa_4m")
Layer.Symbol.Color = moGreen
Map1.Layers.add Layer
Set Layer = New MapLayer
Set Layer.GeoDataset = dc.FindGeoDataset("res2_4m")
Layer.Symbol.Color = moRed
Map1.Layers.add Layer
Map1.Layers("bou2_4p").name = "行政区"
Map1.Layers("roa_4m").name = "道路"
Map1.Layers("res2_4m").name = "城市"
Map1.Layers("river5_polyline").name = "河流"
Command7.Left = (Form1.Width - Command7.Width) / 2
End Sub

Private Sub legend1_LayerDblClick(Index As Integer)
Form2.Show
End Sub

Private Sub load_Click()
Dim lyr As New MapObjects2.MapLayer
Dim name As String
Dim dc As New MapObjects2.DataConnection
CommonDialog1.Filter = "Esri文件(*.shp)|*.shp"
CommonDialog1.ShowOpen
If (Len(CommonDialog1.FileName) = 0) Then Exit Sub
Map1.MousePointer = moHourglass
dc.Database = CurDir
name = CommonDialog1.FileTitle
name = Left(name, Len(name) - 4)
Set lyr.GeoDataset = dc.FindGeoDataset(name)
Map1.Layers.add lyr
Map1.MousePointer = moDefault
End Sub
Private Sub legend1_AfterSetLayerVisible(Index As Integer, isVisible As Boolean)
Map1.Refresh
End Sub
Private Sub Map1_AfterLayerDraw(ByVal Index As Integer, ByVal canceled As Boolean, ByVal hDC As stdole.OLE_HANDLE)
legend1.setMapSource Map1
legend1.LoadLegend True
List1.Clear
For Each lyr In Map1.Layers
    List1.AddItem lyr.name
Next lyr
  If Index > 0 Then Exit Sub
  If recSelection Is Nothing Then Exit Sub
  If Not recSelection.EOF Then
    Map1.DrawShape recSelection, g_symSelection
  End If
  Set recSelection = Nothing
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Toolbar1.Buttons(1).Value = tbrPressed Then
Map1.Extent = Map1.TrackRectangle
ElseIf Toolbar1.Buttons(2).Value = tbrPressed Then
Dim r As New MapObjects2.Rectangle
Set r = Map1.Extent
r.ScaleRectangle 1.2
Map1.Extent = r
ElseIf Toolbar1.Buttons(3).Value = tbrPressed Then
Map1.Pan
End If
End Sub
Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Toolbar1.Buttons(1).Value = tbrPressed Then
Map1.MousePointer = moZoomIn
ElseIf Toolbar1.Buttons(2).Value = tbrPressed Then
Map1.MousePointer = moZoomOut
ElseIf Toolbar1.Buttons(3).Value = tbrPressed Then
Map1.MousePointer = moPan
ElseIf Toolbar1.Buttons(4).Value = tbrPressed Then
Map1.MousePointer = moDefault
End If
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
If Toolbar1.Buttons(4).Value = tbrPressed Then
Set Map1.Extent = Map1.FullExtent
End If
End Sub
Private Sub zoomin_Click()
Dim r As New MapObjects2.Rectangle
Set r = Map1.Extent
r.ScaleRectangle 0.5
Map1.Extent = r
End Sub
Private Sub zoomout_Click()
Dim r As New MapObjects2.Rectangle
Set r = Map1.Extent
r.ScaleRectangle 2#
Map1.Extent = r
End Sub
Private Sub list1_DblClick()
   Dim lyr As MapObjects2.MapLayer
   If List1.ListIndex <> -1 Then
       Map1.Layers.MoveToTop List1.ListIndex
       Map1.Refresh
       List1.Clear
       For Each lyr In Map1.Layers
         List1.AddItem lyr.name
       Next lyr
   End If
End Sub
Private Sub about_Click()
MsgBox ("制作:杨维")
End Sub