程序的源代碼下載地址:

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

最后運行時候的界面:

?

轉載于:https://www.cnblogs.com/sunliming/archive/2010/05/27/1745402.html

總結

以上是生活随笔為你收集整理的[vb+mo] visual baisc 6.0 基于mapobjects 2.4 开发的数字化校园电子地图的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。