[vb+mo] visual baisc 6.0 基于mapobjects 2.4 开发的数字化校园电子地图

程序的源代码下载地址:

https://docs.google.com/

请安装VB6.0企业版(不是企业版运行会报错,因为缺少相应的控件)和ESRI MO2.4

程序的质量一般,因为时间仓促,主要是毕业设计时间仓促.希望大家多多改进.有什么问题可以发邮件欢迎交流.

程序的主窗口代码:

'通用变量定义
Private lyrname As String
Private Const Searchtolpixels = 3
Public mark As Integer
Public fd As Boolean, sx As Boolean, my As Boolean, cX As String
Public lineMy As New MapObjects2.line
Public poly As New MapObjects2.Polygon
Public rect As New MapObjects2.Rectangle
Public cir As New MapObjects2.Ellipse
Public pt1 As New MapObjects2.Point
Public BufPoly As New MapObjects2.Polygon
Dim HasRec As Boolean
Dim recsParcel As MapObjects2.Recordset
Dim sym As New Symbol
Dim SymBuf As New Symbol
Dim SymSel As New Symbol
Dim isLabelShow As Integer
Dim dr1 As DrawRect
Dim dd As String

' 面积计算
Private Sub AreaCal_Click()
mark = 2
Map1.MousePointer = moCross
End Sub

'输入查询地物名称
Private Sub Command1_Click()
If Text1.Text = "" Then
MsgBox "请输入要查询的地物!", vbOKOnly, "提示!"
Else
If HasRec = False Then
End If
'查询三个图层的名称并且显示
For i = 0 To 2
Set mylyr = Map1.Layers(i)
Set recsParcel = mylyr.SearchExpression("名称 like " + "'" + "%" + Text1.Text + "%" + "'")

If i <> 3 Then

End If

Next i
Dim stats As MapObjects2.Statistics
Set stats = recsParcel.CalculateStatistics("FeatureID")
iParcel = stats.Count

If stats.Count < 1 Then
MsgBox "没有找到"

Else: Map1.FlashShape recsParcel.Fields("Shape").Value, 3
If Not recsParcel.EOF Then
form5.ListView1.ListItems.Clear
For Each fld In recsParcel.Fields
Set newItem = form5.ListView1.ListItems.Add
newItem.Text = fld.Name
newItem.SubItems(1) = fld.ValueAsString
Next fld
aString = recsParcel.Fields("名称").ValueAsString
If aString = "运动场" Then
dd = App.Path + "\..\" + "图片" + "\" + "3.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "图书馆" Then
dd = App.Path + "\..\" + "图片" + "\" + "11.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "校行政楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "9.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "B1教学楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "8.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "A1教学楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "2.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "八一路" Then
dd = App.Path + "\..\" + "图片" + "\" + "7.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "弘毅广场" Then

dd = App.Path + "\..\" + "图片" + "\" + "11.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "综合教学楼2" Then
dd = App.Path + "\..\" + "图片" + "\" + "17.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "综合实验楼1" Then
dd = App.Path + "\..\" + "图片" + "\" + "16.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "艺术楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "14.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf Text1.Text = "" Then
Else: dd = App.Path + "\..\" + "图片" + "\" + "13.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
End If
form5.Image1 = LoadPicture(dd)
form5.Show
End If

Map1.Refresh
End If
End If
End Sub

'显示属性窗口
Private Sub Command4_Click()
If Text1.Text = "" Then
MsgBox "请输入要查询的地物!", vbOKOnly, "提示!"
Else
If HasRec = False Then
End If
'查询三个图层的名称并且显示
For i = 0 To 2
Set mylyr = Map1.Layers(i)

Set recsParcel = mylyr.SearchExpression("名称 = " + "'" + Text1.Text + "'")

If i <> 3 Then
End If

Next i
Dim stats As MapObjects2.Statistics
Set stats = recsParcel.CalculateStatistics("FeatureID")
iParcel = stats.Count

If stats.Count < 1 Then
MsgBox "没有找到"

Else: Map1.FlashShape recsParcel.Fields("Shape").Value, 3
If Not recsParcel.EOF Then
form5.ListView1.ListItems.Clear
For Each fld In recsParcel.Fields
'Set Recs = l.SearchByDistance(Loc, theTol, "")
Set newItem = form5.ListView1.ListItems.Add
newItem.Text = fld.Name
newItem.SubItems(1) = fld.ValueAsString
Next fld
aString = recsParcel.Fields("名称").ValueAsString
If aString = "运动场" Then
dd = App.Path + "\..\" + "图片" + "\" + "3.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "图书馆" Then
dd = App.Path + "\..\" + "图片" + "\" + "11.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "校行政楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "9.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "B1教学楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "8.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "A1教学楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "2.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "八一路" Then
dd = App.Path + "\..\" + "图片" + "\" + "7.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "弘毅广场" Then
dd = App.Path + "\..\" + "图片" + "\" + "11.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "综合教学楼2" Then
dd = App.Path + "\..\" + "图片" + "\" + "17.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "综合实验楼1" Then

dd = App.Path + "\..\" + "图片" + "\" + "16.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "艺术楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "14.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
Else: dd = App.Path + "\..\" + "图片" + "\" + "13.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show

End If
form5.Image1 = LoadPicture(dd)
form5.Show
End If

Map1.Refresh
End If
End If
End Sub

' 清理缓冲图形
Private Sub command6_Click()
Me.Map1.TrackingLayer.ClearEvents
Option1.Value = False
Option2.Value = False
Option3.Value = False
Option4.Value = False
Option5.Value = False
End Sub

' 距离量算
Private Sub DistanceCal_Click()
mark = 1
Map1.MousePointer = moCross
End Sub

Sub AddLegend()
' 加载图例
legend1.LoadLegend
' 获得活动图层的索引号
legend1.Active(0) = True
Dim Index As Long
Index = legend1.getActiveLayer
' 如果索引号有效
Exit Sub
End Sub

Private Sub Form_Load()
Form1.Picture = LoadPicture()
Call addlayers
Call SetUpRenderers
Call SetUpPointLabelRenderers
Call SetUpLineLabelRenderers
updateScale
legend1.Active(0) = True
legend1.setMapSource Map1
legend1.LoadLegend True
legend1.Visible = True
'将图层名称添加到列表框里
Dim mylyr As MapObjects2.MapLayer
Map1.Refresh
'详细定义符号
Text3.Text = "100"
Map1.TrackingLayer.SymbolCount = 4
With Map1.TrackingLayer.Symbol(0)
.SymbolType = moPointSymbol
.Style = moTriangleMarker
.Color = moRed
.Size = 3
End With

With Map1.TrackingLayer.Symbol(1)
.SymbolType = moLineSymbol
.Color = moRed
.Size = 3
End With

With Map1.TrackingLayer.Symbol(2)
.SymbolType = moFillSymbol
.Style = moGrayFill
.Color = moRed
.OutlineColor = moRed
End With

With Map1.TrackingLayer.Symbol(3)
.SymbolType = moFillSymbol
.Style = moGrayFill
.Color = moBlue
.OutlineColor = moBlue
End With
End Sub

'添加数据方法
Sub addlayers()
Dim DCONN As New MapObjects2.DataConnection
DCONN.Database = App.Path + "\..\" + "数据" + "\"
If Not DCONN.Connect Then
MsgBox "没找到数据"
End If
'添加东区面
Dim myMaplayer As New MapObjects2.MapLayer
Set myMaplayer.GeoDataset = DCONN.FindGeoDataset("东区面")
myMaplayer.Symbol.Color = moWhite
Map1.Layers.Add myMaplayer
AddLegend
'添加东区线
Set myMaplayer = New MapObjects2.MapLayer
Set myMaplayer.GeoDataset = DCONN.FindGeoDataset("东区线")
myMaplayer.Symbol.Color = moLightGray
myMaplayer.Symbol.Style = moSolidLine
myMaplayer.Symbol.Size = 2
Map1.Layers.Add myMaplayer
AddLegend
'添加东区点
Set myMaplayer = New MapObjects2.MapLayer
Set myMaplayer.GeoDataset = DCONN.FindGeoDataset("东区点")
myMaplayer.Symbol.Color = moTeal
myMaplayer.Symbol.Style = moSolidLine
myMaplayer.Symbol.Size = 3
Map1.Layers.Add myMaplayer
AddLegend
'map2中添加底图
Set yMaplayer = New MapObjects2.MapLayer
Set yMaplayer.GeoDataset = DCONN.FindGeoDataset("东区面")
yMaplayer.Symbol.Color = RGB(232, 241, 13)
yMaplayer.Symbol.Style = mosolide
Map2.Layers.Add yMaplayer
End Sub

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

Private Sub legend1_LayerDblClick(Index As Integer)
Dim i As Integer
i = legend1.getActiveLayer
Dim str As String
str = Map1.Layers.Item(i).Name
If str = "东区点" Then
Set Map1.Layers("东区点").Renderer = Nothing
SetUpPointLabelRenderers
CommonDialog1.ShowColor
Map1.Layers("东区点").Symbol.Color = CommonDialog1.Color
legend1.LoadLegend
ElseIf str = "东区线" Then
If MsgBox("修改颜色", vbYesNo) = vbNo Then
Map1.Layers("东区线").Symbol.Color = moLightGray
legend1.LoadLegend
Else
Set Map1.Layers("东区线").Renderer = Nothing
SetUpLineLabelRenderers
CommonDialog1.ShowColor
Map1.Layers("东区线").Symbol.Color = CommonDialog1.Color
legend1.LoadLegend
End If
ElseIf str = "东区面" Then
If MsgBox("修改颜色", vbYesNo) = vbNo Then
SetUpRenderers
legend1.LoadLegend
Else
Set Map1.Layers("东区面").Renderer = Nothing
CommonDialog1.ShowColor
Map1.Layers("东区面").Symbol.Color = CommonDialog1.Color
legend1.LoadLegend
End If
End If
Map1.Refresh
End Sub

Private Sub legend1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
Dim str As String
i = legend1.getActiveLayer
'MsgBox i
If i = -1 Then i = 2

str = Map1.Layers(i).Name
lyrname = str
' i = 0
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
Dim mylyr As MapLayer
Dim myrcs As MapObjects2.Recordset
Dim iCount As Integer
Dim i As Integer
iCount = Map1.Layers.Count
HasRec = False
If Text1.Text <> "" Then
'模糊查询部分<三个图层一起查询>
For i = 0 To iCount - 1
Set mylyr = Map1.Layers(i)
Set myrcs = mylyr.SearchExpression("名称 like " + "'" + "%" + Text1.Text + "%" + "'")
Set g_symSelection = New MapObjects2.Symbol

With g_symSelection
.SymbolType = Map1.Layers(i).Symbol.SymbolType
.Color = moRed
.Size = 5.2
End With

If mylyr.shapeType = moShapeTypePolygon Then
g_symSelection.Outline = False
End If

If Not myrcs.EOF Then
Map1.DrawShape myrcs, g_symSelection
HasRec = True
End If
Next i
End If
Map1.Refresh
End Sub

Private Sub Map1_BeforeLayerDraw(ByVal Index As Integer, ByVal hdc As stdole.OLE_HANDLE)

Map1.Refresh
Map2.Refresh
End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'********************************距离统计******************************************
If mark = 1 Then
Dim line1 As MapObjects2.line ' Line Object: A Line object represents a
' geometric shape that has two or more vertices.
Set line1 = Map1.TrackLine ' TrackLine Method: Rubber-bands a multi-point
' line on the Map and returns a Line object.
Map1.TrackingLayer.Refresh True
Me.StatusBar1.Panels(5).Text = "地图距离为: " + Format(line1.Length, "#.00") + " Meters"
' Panels属性功能：返回对Panel对象的（Panels）集合的引用 Length Property:
' Returns the length of a Line object in map units.
End If
'*********************************面积统计*****************************************
If mark = 2 Then
Dim poly1 As MapObjects2.Polygon
Set poly1 = Map1.TrackPolygon
Map1.TrackingLayer.Refresh True
Me.StatusBar1.Panels(5).Text = "面积为: " + Format(poly1.Area, "#.00") + " Square Meters"
' Area Property: Returns the area of an object in square map units.
End If
'**********************************************************************************
Dim r As MapObjects2.Rectangle
If fd = True Then '放大
Map1.MousePointer = moZoomIn
Set r = Map1.TrackRectangle
Set Map1.Extent = r
Map1.Refresh
Map2.Refresh
updateScale
End If

If my = True Then
Map1.Pan '漫游
Map1.MousePointer = moPan
End If

If sx = True Then '缩小

Map1.MousePointer = moZoomOut
Dim Loc As New MapObjects2.Point
Dim mapwidth As Double, mapheigth As Double
Set Loc = Map1.ToMapPoint(X, Y)
Set r = Map1.Extent
mapwidth = Map1.Extent.Width
mapheight = Map1.Extent.Height
r.Right = Loc.X + mapwidth
r.Left = Loc.X - mapwidth
r.Top = Loc.Y + mapheight
r.Bottom = Loc.Y - mapheight
Set Map1.Extent = r
Map1.Refresh
Map2.Refresh
updateScale
End If
'显示属性<分图层显示>
If Toolbar1.Buttons(5).Value = 1 Then
mark = 0
Map1.MousePointer = moIdentify
If lyrname <> "" Then
Call identify(X, Y)
Else
MsgBox "请在图层显示框中单击地物所在的图层!", vbOKOnly, "提示!"
End If
End If

'点缓冲
If Option1.Value Then
Dim pt As New MapObjects2.Point
Dim eventPt As New MapObjects2.GeoEvent
Dim buffPt As New MapObjects2.Polygon
Dim buffEventPt As New MapObjects2.GeoEvent

Set pt = Map1.ToMapPoint(X, Y)
Set eventPt = Map1.TrackingLayer.AddEvent(pt, 0)
Set buffPt = pt.Buffer(Text3.Text, Map1.FullExtent)

Set buffEventPt = Map1.TrackingLayer.AddEvent(buffPt, 3)

'线缓冲
ElseIf Option2.Value Then
Dim line As New MapObjects2.line
Dim eventLine As New MapObjects2.GeoEvent
Dim buffLine As New MapObjects2.Polygon
Dim buffEventLine As New MapObjects2.GeoEvent

Set line = Map1.TrackLine
Set eventLine = Map1.TrackingLayer.AddEvent(line, 1)
Set buffLine = line.Buffer(Text3.Text, Map1.FullExtent)
Set buffEventLine = Map1.TrackingLayer.AddEvent(buffLine, 3)

'矩形缓冲
ElseIf Option3.Value Then
Dim rect As New MapObjects2.Rectangle
Dim eventRect As New MapObjects2.GeoEvent
Dim buffRect As New MapObjects2.Polygon
Dim buffEventRect As New MapObjects2.GeoEvent

Set rect = Map1.TrackRectangle
Set eventRect = Map1.TrackingLayer.AddEvent(rect, 2)
Set buffRect = rect.Buffer(Text3.Text, Map1.FullExtent)
Set buffEventRect = Map1.TrackingLayer.AddEvent(buffRect, 3)

'多边形缓冲
ElseIf Option4.Value Then
Dim poly As New MapObjects2.Polygon
Dim eventPoly As New MapObjects2.GeoEvent
Dim buffPoly As New MapObjects2.Polygon
Dim buffEventPoly As New MapObjects2.GeoEvent

Set poly = Map1.TrackPolygon
Set eventPoly = Map1.TrackingLayer.AddEvent(poly, 2)
Set buffPoly = poly.Buffer(Text3.Text, Map1.FullExtent)
Set buffEventPoly = Map1.TrackingLayer.AddEvent(buffPoly, 3)

'椭圆缓冲

ElseIf Option5.Value Then
Dim arect As New MapObjects2.Rectangle
Dim elli As New MapObjects2.Ellipse
Dim eventElli As New MapObjects2.GeoEvent
Dim buffElli As New MapObjects2.Polygon
Dim buffEventElli As New MapObjects2.GeoEvent

Set arect = Map1.TrackRectangle
elli.Top = arect.Top
elli.Bottom = arect.Bottom
elli.Left = arect.Left
elli.Right = arect.Right

Set eventElli = Map1.TrackingLayer.AddEvent(elli, 2)
Set buffElli = elli.Buffer(Text3.Text, Map1.FullExtent)
Set buffEventElli = Map1.TrackingLayer.AddEvent(buffElli, 3)
'Else: MsgBox "请选择缓冲类型并且输入缓冲距离"

End If

End Sub

Private Sub identify(X As Single, Y As Single) '******地物属性查询*******************

Dim theTol As Double
Dim Loc As New Point

If lyrname = "" Then
MsgBox "请选中要查询的图层"
Else
Set l = Map1.Layers(lyrname)
Set Loc = Map1.ToMapPoint(X, Y)
theTol = Map1.ToMapDistance(Searchtolpixels * Screen.TwipsPerPixelX)

Set Recs = l.SearchByDistance(Loc, theTol, "")

If Not Recs.EOF Then
form5.ListView1.ListItems.Clear
For Each fld In Recs.Fields
'Set Recs = l.SearchByDistance(Loc, theTol, "")
Set newItem = form5.ListView1.ListItems.Add
newItem.Text = fld.Name
newItem.SubItems(1) = fld.ValueAsString
Next fld
aString = Recs.Fields("名称").ValueAsString

If aString = "运动场" Then
dd = App.Path + "\..\" + "图片" + "\" + "3.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "图书馆" Then
dd = App.Path + "\..\" + "图片" + "\" + "11.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "校行政楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "9.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "B1教学楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "8.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "A1教学楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "2.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "八一路" Then
dd = App.Path + "\..\" + "图片" + "\" + "7.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "弘毅广场" Then
dd = App.Path + "\..\" + "图片" + "\" + "11.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "综合教学楼2" Then
dd = App.Path + "\..\" + "图片" + "\" + "17.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "综合实验楼1" Then
dd = App.Path + "\..\" + "图片" + "\" + "16.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
ElseIf aString = "艺术楼" Then
dd = App.Path + "\..\" + "图片" + "\" + "14.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
Else: dd = App.Path + "\..\" + "图片" + "\" + "13.jpg"
form5.Image1 = LoadPicture(dd)
form5.Show
End If
End If
End If
End Sub

Private Sub Map2_AfterTrackingLayerDraw(ByVal hdc As stdole.OLE_HANDLE)
Dim sym As New MapObjects2.Symbol ' Symbol Object: A Symbol object consisits
' of attributes that control how a features or graphic shape in displayed.
sym.OutlineColor = moGreen ' OutlineColor Property: Returns or sets the outline
' color of a Polygon object's Symbol.
sym.Style = moTransparentFill ' Style Property: Returns or sets the style of
' a Symbol object.
Map2.DrawShape Map1.Extent, sym
End Sub

Private Sub Map2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
' convert to map point
Dim p As MapObjects2.Point
Set p = Map2.ToMapPoint(X, Y)

' if the click happended inside the indicator, then start dragging
If Map1.Extent.IsPointIn(p) Then ' IsPointIn Method: Returns a value that indicates
' whether a Point falls within an object.
Set dr1 = New DrawRect
dr1.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 dr1 Is Nothing Then
dr1.DragMove X, Y
End If
' 鼠标在鹰眼上移动，状态栏中显示相应的坐标
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_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not dr1 Is Nothing Then
Set Map1.Extent = dr1.DragFinish(X, Y)
Set dr1 = Nothing
End If
End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'更新状态条的坐标显示
Dim curPoint As Point
Dim curX As Double
Dim curY As Double
'将屏幕目标转换为地理坐标
Set curPoint = Map1.ToMapPoint(X, Y)
curX = curPoint.X
curY = curPoint.Y
'压缩取小数点后2位
Dim cX As String, cy As String
cX = curX
cy = curY
cX = Left(cX, InStr(cX, ".") + 2)
cy = Left(cy, InStr(cy, ".") + 2)
StatusBar1.Panels(2).Text = "X := " & cX
StatusBar1.Panels(3).Text = "Y := " & cy
End Sub

' 更新比例尺
Public Sub updateScale()
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
isLabelShow = ScaleBar1.RFScale
'MsgBox isLabelShow
StatusBar1.Panels(4).Text = "比例尺 1 : " & Format$(ScaleBar1.RFScale, "###,###,###,###,###")
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
If Toolbar1.Buttons(1).Value = tbrPressed Then
Map1.MousePointer = moZoomIn '鼠标成放大形状
fd = True
sx = False
my = False
mark = 0
End If

If Toolbar1.Buttons(2).Value = tbrPressed Then
Map1.MousePointer = moZoomOut '鼠标成缩小状
sx = True
my = False
fd = False
mark = 0
End If

If Toolbar1.Buttons(3).Value = tbrPressed Then
Map1.MousePointer = moPan '鼠标成漫游状
my = True
sx = False
fd = False
mark = 0
End If

If Toolbar1.Buttons(4).Value = tbrPressed Then
Map1.MousePointer = moArrow '全图显示
Map1.Extent = Map1.FullExtent
Map1.Refresh
Toolbar1.Buttons(4).Value = tbrUnpressed
mark = 0
End If
If Toolbar1.Buttons(5).Value = tbrPressed Then
Map1.MousePointer = moIdentify
End If
If Toolbar1.Buttons(6).Value = tbrPressed Then
Map1.MousePointer = moCross '鼠标成十字
mark = 1
End If
If Toolbar1.Buttons(7).Value = tbrPressed Then
Map1.MousePointer = moCross '鼠标成十字
mark = 2
End If
If Toolbar1.Buttons(8).Value = tbrPressed Then
Option1.Value = True
' MsgBox "请在右面板中选择缓冲区的类型及距离并且在地图上操作"
mark = 0
End If
If Toolbar1.Buttons(9).Value = tbrPressed Then
Map1.MousePointer = moArrow
mark = 3
IsClear = Not IsClear
Text1.Text = ""
mark = 0
Me.Map1.TrackingLayer.ClearEvents
Option1.Value = False
Option2.Value = False
Option3.Value = False
Option4.Value = False
Option5.Value = False
Map1.Refresh
Toolbar1.Buttons(9).Value = tbrUnpressed
End If
End Sub

Private Sub 打印_Click()
Map1.PrintMap "MyMap", "", True
End Sub

Private Sub 地点查询_Click()
MsgBox "请在右面板输入要查询的地名然后点击查询按钮"
Map1.MousePointer = moIdentify
my = True
fd = False
sx = False
End Sub

'判断实现地图的放大，缩小，漫游，全图
Private Sub 放大_Click()
Map1.MousePointer = moZoomIn
fd = True
my = False
sx = False
updateScale
mark = 0
End Sub

Private Sub 漫游_Click()
Map1.MousePointer = moPan
my = True
fd = False
sx = False
mark = 0
End Sub

Private Sub 全图_Click()
Set Map1.Extent = Map1.FullExtent
updateScale
mark = 0
End Sub

Private Sub 缩小_Click()
Map1.MousePointer = moZoomOut
sx = True
my = False
fd = False
updateScale
mark = 0
End Sub

Private Sub 关于_Click()
Form4.Show
mark = 0
End Sub

Private Sub 退出_Click()
End
End Sub

'加载图片
Private Sub 许昌学院风光图_Click()
Form3.Show
End Sub
'加在规划图
Private Sub 许昌学院规划图_Click()
Form2.Show
End Sub

' 按类型显示图层颜色
Sub SetUpRenderers()
Dim ly As New MapObjects2.MapLayer
Set ly = Map1.Layers("东区面")
Set ly.Renderer = New ValueMapRenderer
ly.Renderer.SymbolType = moFillSymbol
ly.Renderer.Field = "类型"

ly.Renderer.ValueCount = 9
ly.Renderer.Value(0) = "水域"
ly.Renderer.Value(1) = "道路"
ly.Renderer.Value(2) = "公寓"
ly.Renderer.Value(3) = "教学楼"
ly.Renderer.Value(4) = "绿地"
ly.Renderer.Value(5) = "林地"
ly.Renderer.Value(6) = "办公楼"
ly.Renderer.Value(7) = "运动场"
ly.Renderer.Value(8) = "其他"

'为不同类型设置不同颜色
ly.Renderer.Symbol(0).Color = RGB(20, 157, 255)
ly.Renderer.Symbol(1).Color = moLightGray
ly.Renderer.Symbol(2).Color = moWhite
ly.Renderer.Symbol(3).Color = moWhite
ly.Renderer.Symbol(4).Color = moGreen
ly.Renderer.Symbol(5).Color = moGreen
ly.Renderer.Symbol(6).Color = moWhite
ly.Renderer.Symbol(7).Color = RGB(251, 197, 4)
ly.Renderer.Symbol(8).Color = moLightYellow
End Sub

' 添加点注记
Sub SetUpPointLabelRenderers()
Dim ly1 As New MapObjects2.MapLayer
Dim fnt1 As New StdFont
Set ly1 = Map1.Layers("东区点")
fnt1.Name = "Arial"
fnt1.Bold = False
fnt1.Size = 2
fnt1.Strikethrough = True
Dim lr1 As New MapObjects2.LabelRenderer
ly1.Renderer = lr1

With lr1
.Field = "名称"
.SymbolCount = 1
.AllowDuplicates = True
.SplinedText = True
.Symbol(0).Color = moRed
End With
End Sub

' 添加线注记
Sub SetUpLineLabelRenderers()
Dim ly2 As New MapObjects2.MapLayer
Dim fnt2 As New StdFont
Dim lr2 As New LabelRenderer
Set ly2 = Map1.Layers("东区线")
fnt2.Name = "Arial"
fnt2.Bold = True
fnt2.Size = 2
fnt2.Strikethrough = True
ly2.Renderer = lr2

With lr2
.Field = "名称"
.SymbolCount = 1
.AllowDuplicates = True
.SplinedText = False
.Symbol(0).Color = moPurple
End With
End Sub

最后运行时候的界面: