main.frm

vb+mo二次开发实现校园内的属性查询功能

            Picture         =   "main.frx":3766
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin VB.Line Line1 
      X1              =   3960
      X2              =   6360
      Y1              =   2400
      Y2              =   4440
   End
   Begin VB.Menu file 
      Caption         =   "文件"
      WindowList      =   -1  'True
      Begin VB.Menu print 
         Caption         =   "打印"
      End
      Begin VB.Menu add 
         Caption         =   "加入图层"
      End
      Begin VB.Menu quit 
         Caption         =   "退出"
         Checked         =   -1  'True
      End
   End
   Begin VB.Menu layers 
      Caption         =   "图层"
      Begin VB.Menu zoomin 
         Caption         =   "放大"
      End
      Begin VB.Menu zoomout 
         Caption         =   "缩小"
      End
      Begin VB.Menu return 
         Caption         =   "还原"
      End
   End
   Begin VB.Menu check 
      Caption         =   "查询"
      Begin VB.Menu mousedown 
         Caption         =   "点击查询"
      End
      Begin VB.Menu character 
         Caption         =   "属性查询"
      End
   End
   Begin VB.Menu manage 
      Caption         =   "管理"
      Begin VB.Menu stdmanage 
         Caption         =   "学生管理"
      End
      Begin VB.Menu mapdatamanage 
         Caption         =   "地图数据管理"
      End
   End
   Begin VB.Menu help 
      Caption         =   "帮助"
      Begin VB.Menu about 
         Caption         =   "关于"
      End
      Begin VB.Menu instruction 
         Caption         =   "使用说明"
      End
   End
End
Attribute VB_Name = "frmmain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim symgtext As New mapobjects2.TextSymbol
Dim sym1 As New mapobjects2.Symbol
Dim p1 As mapobjects2.Point
Private collGtextStrings As New VBA.Collection
Private collGtextPoints As New VBA.Collection



Private Sub about_Click()
'frmAbout.Show
End Sub

Private Sub add_Click()
Dim shapelayer As New mapobjects2.MapLayer
Dim dc As New mapobjects2.DataConnection
Dim gds As mapobjects2.GeoDataset
Dim fname As String

CommonDialog1.Filter = "ESRI Shapefile (*.shp)|*.shp"
CommonDialog1.CancelError = True

CommonDialog1.ShowOpen
If Len(CommonDialog1.FileName) = 0 Then Exit Sub

dc.Database = CurDir
If Not dc.Connect Then Exit Sub
fname = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4)
Set gds = dc.FindGeoDataset(fname)
If gds Is Nothing Then Exit Sub

Set shapelayer.GeoDataset = gds
Map1.layers.add shapelayer
legend1.LoadLegend
Exit Sub


End Sub

Private Sub character_Click()
fsearch.Show
End Sub

Private Sub Command1_Click()
Map1.TrackingLayer.ClearEvents
Map1.Refresh
End Sub

Private Sub Form_Load()


symgtext.Color = moBlack
symgtext.Font.Size = 10
Dim tl As mapobjects2.TrackingLayer
  Set tl = Map1.TrackingLayer
  With tl
    .SymbolCount = 3
    .Symbol(0).SymbolType = moPointSymbol
    .Symbol(0).Style = moTriangleMarker
    .Symbol(0).Color = moRed
    .Symbol(0).Size = 4
    .Symbol(1).SymbolType = moLineSymbol
    .Symbol(1).Style = moSolidLine
    .Symbol(1).Color = moRed
    .Symbol(1).Size = 2
    .Symbol(2).SymbolType = moFillSymbol
    .Symbol(2).Style = moTransparentFill
    .Symbol(2).OutlineColor = moRed
    .Symbol(2).Size = 2
End With

Call loadshape

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)
Dim symselection As mapobjects2.Symbol
Dim recselection As mapobjects2.Recordset
Dim labeltext As String
Call refreshscale
Dim i As Long
If collGtextStrings.Count > 0 Then
  For i = 1 To collGtextStrings.Count
    Map1.DrawText collGtextStrings(i), collGtextPoints(i), symgtext
  Next
End If
If fsearch.flag = 1 Then
    Set symselection = New mapobjects2.Symbol
    With symselection
        .SymbolType = Map1.layers(lname).Symbol.SymbolType
        .Color = moRed
    End With
    Set recselection = Map1.layers(fsearch.lname).SearchExpression(fsearch.strexpression)
    If Map1.layers(fsearch.lname).Records.Fields(fsearch.Combo2.List(fsearch.Combo2.ListIndex)).Type = moString Then
        strexpression = fsearch.Combo2.List(fsearch.Combo2.ListIndex) & fsearch.Combo3.List(fsearch.Combo3.ListIndex) & _
        "'" & fsearch.Text1.Text & "'"
    Else
        strexpression = fsearch.Combo2.List(fsearch.Combo2.ListIndex) & fsearch.Combo3.List(fsearch.Combo3.ListIndex) & _
        fsearch.Text1.Text
    End If
    If Not recselection.EOF Then
        Map1.DrawShape recselection, symselection
        Set recselection = Nothing
    Else
        MsgBox "未找到符合要求的对象"
        Exit Sub
    End If
End If
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim layer As MapLayer
Dim curRectangle As Rectangle
Dim tl As mapobjects2.TrackingLayer
    Set tl = Map1.TrackingLayer
    tl.SymbolCount = 3

If Toolbar1.Buttons(3).Value = 1 Then
    Map1.MousePointer = moZoomIn
   Set Map1.Extent = Map1.TrackRectangle
ElseIf Toolbar1.Buttons(4).Value = 1 Then
    Map1.MousePointer = moZoomOut
    Set r = Map1.Extent
    r.ScaleRectangle 1.5
    Map1.Extent = r
ElseIf Toolbar1.Buttons(6).Value = 1 Then
    Map1.MousePointer = moPan
    Map1.Pan
ElseIf Toolbar1.Buttons(10).Value = 1 Then
    Call frmattribute.Identify(x, y)

ElseIf Toolbar1.Buttons(11).Value = 1 Then
        Map1.MousePointer = moCross
        Dim strGText As String
        Dim ptGText As mapobjects2.Point
        strGText = InputBox("请输入文本标签：")
        Set ptGText = Map1.ToMapPoint(x, y)
        collGtextStrings.add strGText
        collGtextPoints.add ptGText
ElseIf Toolbar1.Buttons(12).Value = 1 Then
        Map1.MousePointer = moCross
        Dim ptGraphic As mapobjects2.Point
        Set ptGraphic = Map1.ToMapPoint(x, y)
        tl.AddEvent ptGraphic, 0
        
ElseIf Toolbar1.Buttons(13).Value = 1 Then
        Map1.MousePointer = moCross
        Dim lnGraphic As mapobjects2.Line
        Set lnGraphic = Map1.TrackLine
        tl.AddEvent lnGraphic, 1
        With Map1.TrackingLayer.Symbol(0)
            .SymbolType = moLineSymbol
        End With
ElseIf Toolbar1.Buttons(14).Value = 1 Then
        Map1.MousePointer = moCross
        Dim rectGraphic As mapobjects2.Rectangle
        Set rectGraphic = Map1.TrackRectangle
        tl.AddEvent rectGraphic, 2
        With Map1.TrackingLayer.Symbol(0)
            .SymbolType = moLineSymbol
           
        End With
ElseIf Toolbar1.Buttons(15).Value = 1 Then
        Map1.MousePointer = moCross
        Dim polyGraphic As mapobjects2.Polygon
        Set polyGraphic = Map1.TrackPolygon
        tl.AddEvent polyGraphic, 2
        With Map1.TrackingLayer.Symbol(0)
            .SymbolType = moLineSymbol
            
         End With
 ElseIf Toolbar1.Buttons(16).Value = 1 Then
        Map1.MousePointer = moCross
        Dim cirGraphic As mapobjects2.Ellipse
        Set cirGraphic = Map1.TrackCircle
        tl.AddEvent cirGraphic, 2
        With Map1.TrackingLayer.Symbol(0)
            .SymbolType = moLineSymbol
            
        End With
End If

Map1.Refresh
  
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 mapdatamanage_Click()

'frmmanage.Show
End Sub

Private Sub mousedown_Click()
Map1.MousePointer = moIdentify
Toolbar1.Buttons(10).Value = 1
End Sub

Private Sub print_Click()
frmprint.Show
End Sub

Private Sub quit_Click()
End
End Sub

Private Sub return_Click()
Map1.MousePointer = moZoom
Toolbar1.Buttons(5).Value = 1
End Sub

Private Sub stdmanage_Click()
'window1.Show
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
If Toolbar1.Buttons(5).Value = 1 Then
    Map1.MousePointer = moZoom
   Set Map1.Extent = Map1.FullExtent
ElseIf Toolbar1.Buttons(9).Value = 1 Then
    fsearch.Show
ElseIf Toolbar1.Buttons(1).Value = 1 Then
    frmprint.Show
    Toolbar1.Buttons(1).Value = 0
ElseIf Toolbar1.Buttons(17).Value = 1 Then
    Map1.TrackingLayer.ClearEvents
End If
End Sub


Private Sub refreshscale()
ScaleBar1.MapExtent.MaxX = Map1.Extent.Right
ScaleBar1.MapExtent.MinX = Map1.Extent.Left
ScaleBar1.MapExtent.MaxY = Map1.Extent.Top
ScaleBar1.MapExtent.MaxY = Map1.Extent.Bottom

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(1) = "比例尺为：1: " & Format$(ScaleBar1.RFScale, "###,###,###,###,###")
End Sub

Sub loadshape()
Dim comm As adodb.Command
Dim cnn As adodb.Connection
Dim rs As adodb.Recordset
Dim cnnrs As adodb.Connection
Dim shapelayer As New mapobjects2.MapLayer
Dim dc As New mapobjects2.DataConnection
Dim gds As mapobjects2.GeoDataset
Dim fname As String
Dim cno As Integer
Dim strvalue As String

legend1.setMapSource Map1

Set comm = New adodb.Command
Set cnn = New adodb.Connection
Set cnnrs = New adodb.Connection

cnn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\data\database\ecitgis.mdb;Persist Security Info=False"
cnn.CursorLocation = adUseServer
cnn.Open

Set comm.ActiveConnection = cnn
comm.CommandText = "select * from layer where disp=1 order by 编号 ASC"
comm.CommandType = adCmdText

Set rs = comm.Execute
rs.Close
rs.LockType = adLockOptimistic
rs.Open
dc.Database = App.Path + "\data\map"
    If Not dc.Connect Then
        MsgBox "在指定文件夹下没找到图层数据文件"
        End
    End If
Set shapelayer.Renderer = New LabelRenderer
    shapelayer.Renderer.Field = "name"
    shapelayer.Renderer.AllowDuplicates = True
Do While Not rs.EOF
    Set shapelayer = New MapLayer
    fname = rs("layername")
    Set gds = dc.FindGeoDataset(fname)
    shapelayer.Symbol.Color = RGB(Val(rs("red")), Val(rs("green")), Val(rs("blue")))
    If gds Is Nothing Then Exit Sub
    Set shapelayer.GeoDataset = gds
    Map1.layers.add shapelayer
    fsearch.Combo1.AddItem (fname)
    
    
    rs.MoveNext
Loop
    
 Set Map1.Extent = Map1.FullExtent
legend1.LoadLegend
Exit Sub
End Sub

Private Sub zoomin_Click()
Map1.MousePointer = moZoomIn
Toolbar1.Buttons(3).Value = 1
End Sub

Private Sub zoomout_Click()
Map1.MousePointer = moZoomOut
Toolbar1.Buttons(4).Value = 1
End Sub