Option Explicit
Dim selRecs As MapObjects2.Recordset
'英尺與米的單位轉(zhuǎn)換常量
Dim f_to_m As Double
Dim m_to_f As Double
Dim text_height As Double
Dim scale_width As Double
Dim theBenEasting As Long
Dim theBenNorthing As Long
Dim i As Integer
Private Sub DrawRecordset(recs As MapObjects2.Recordset)
'顯示被選中的山峰
If Not recs Is Nothing Then
Dim sym As New MapObjects2.Symbol
sym.SymbolType = moPointSymbol
sym.Color = moYellow
sym.Style = moTriangleMarker
sym.Size = 6
Map1.DrawShape recs, sym
End If
End Sub
Private Sub Form_Load()
'初始化
Set selRecs = Nothing
f_to_m = 0.3048037
m_to_f = 3.2808
text_height = 2000
scale_width = 50000
theBenEasting = 216600
theBenNorthing = 771300
Dim dc As New DataConnection
dc.Database = "D:Program FilesESRIMapObjects2SamplesDataScotland"
If Not dc.Connect Then Exit Sub
Dim Scotcoast As New MapObjects2.MapLayer
Scotcoast.GeoDataset = dc.FindGeoDataset("scotcoast")
Scotcoast.Symbol.Color = moLightYellow
Map1.Layers.Add Scotcoast
Dim Mountains As New MapObjects2.MapLayer
Mountains.GeoDataset = dc.FindGeoDataset("mountains")
Mountains.Symbol.Color = moWhite
Mountains.Symbol.Size = 6
Mountains.Symbol.Style = moTriangleMarker
Map1.Layers.Add Mountains
Dim Mountainslp As New MapObjects2.MapLayer
Mountainslp.GeoDataset = dc.FindGeoDataset("mountains")
Mountainslp.Symbol.Size = 0
Map1.Layers.Add Mountainslp
VRen.Value = True
End Sub
Private Sub selection_enable(bool As Boolean)
sel2d.Enabled = bool
sel3d.Enabled = bool
If sel3d.Value Then
ceiling.Enabled = bool
floor.Enabled = bool
End If
End Sub
Public Sub selrect(rect As MapObjects2.Rectangle)
'查詢二維矩形或三維加入收藏 立方體中的山峰
If (sel3d.Value) Then
'如果是三維立方體，則設(shè)置floor屬性和ceiling屬性
rect.floor = floor.Text
rect.ceiling = ceiling.Text
End If
Set selRecs = Map1.Layers(0).SearchShape(rect, moContaining, "")
clue.Caption = selRecs.Count & "個山峰已被選擇"
Map1.TrackingLayer.Refresh True
End Sub
Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
If selRecs Is Nothing Then
Exit Sub
End If
DrawRecordset selRecs
End Sub
Private Sub Map1_BeforeLayerDraw(ByVal index As Integer, ByVal hDC As stdole.OLE_HANDLE)
If Map1.Extent.Width > scale_width Then
lPlacer.Enabled = False
Map1.Layers(0).Visible = False
Else
lPlacer.Enabled = True
make_LPlacer
Map1.Layers(0).Visible = lPlacer
End If
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Toolbar1.Buttons("zoomin").Value = 1 Then
Map1.Extent = Map1.TrackRectangle
ElseIf Toolbar1.Buttons("zoomout").Value = 1 Then
Dim r As MapObjects2.Rectangle
Set r = Map1.Extent
r.ScaleRectangle 1.5
Map1.Extent = r
ElseIf Toolbar1.Buttons("pan").Value = 1 Then
Map1.Pan
ElseIf Toolbar1.Buttons("rect").Value = 1 Then
Dim rect As MapObjects2.Rectangle
Set rect = Map1.TrackRectangle
If (rect.Width > 0) Then
Call selrect(rect)
End If
End If
End Sub
Private Sub NoRen_Click()
'“無”單選框鼠標(biāo)點擊事件響應(yīng)代碼
If NoRen Then
Map1.Layers(1).Renderer = Nothing
pictureleg.Picture = LoadPicture()
Map1.Refresh
End If
End Sub
Private Sub sel2d_Click()
floor.Enabled = False
ceiling.Enabled = False
MsgBox "將選擇二維立方體內(nèi)的山峰，忽略Z值"
Map1.MousePointer = moCross
Toolbar1.Buttons("rect").Value = 1
End Sub Private Sub make_LPlacer()
Dim lp As New MapObjects2.LabelPlacer
Dim fnt As New StdFont
fnt.Name = "Arial"
fnt.Bold = True
With lp
Set .DefaultSymbol.Font = fnt
.UseDefault = True
.DefaultSymbol.Height = text_height * Map1.Extent.Height / scale_width
.Field = "name"
.DrawBackground = True
End With
Map1.Layers(0).Renderer = lp
End Sub
Private Sub sel3d_Click()
floor.Enabled = True
ceiling.Enabled = True
MsgBox "將選擇三維立方體內(nèi)的山峰，立方體的底部為" & floor & "，頂部為" & ceiling
Map1.MousePointer = moCross
Toolbar1.Buttons("rect").Value = 1
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComCtlLib.Button)
On Error Resume Next
Select Case Button.Key
Case "zoomin"
'應(yīng)做:添加 'zoomin' 按鈕代碼。
Map1.MousePointer = moZoomIn
Call selection_enable(False)
Case "zoomout"
'應(yīng)做:添加 'zoomout' 按鈕代碼。
Map1.MousePointer = moZoomOut
Call selection_enable(False)
Case "pan"
'應(yīng)做:添加 'pan' 按鈕代碼。
Map1.MousePointer = moPan
Call selection_enable(False)
Case "rect"
'應(yīng)做:添加 'arrow' 按鈕代碼。
Map1.MousePointer = moCross
Call selection_enable(False)
Case "globe"
'應(yīng)做:添加 'globe' 按鈕代碼。
Map1.MousePointer = moDefault
Map1.Extent = Map1.FullExtent
End Select
End Sub
Private Sub VRen_Click()
Dim VRen As New MapObjects2.ValueMapRenderer
With VRen
'3種類型的山峰
.ValueCount = 3
.Field = "type"
.SymbolType = moPointSymbol
.Value(0) = "Munro"
.Value(1) = "Corbett"
.Value(2) = "Other"
'設(shè)置每種山峰的顏色
.SymbolType = moPointSymbol
.Symbol(0).Color = moBlue
.Symbol(1).Color = moRed
.Symbol(2).Color = moGreen
'設(shè)置symbol屬性
For i = 0 To .ValueCount - 1
.Symbol(i).Size = 6
.Symbol(i).Style = moTriangleMarker
Next i
End With
'將ValueMapRenderer賦值給Maplayer
Set Map1.Layers(1).Renderer = VRen
pictureleg.Picture = LoadPicture(App.Path + "classleg.bmp")
Map1.Refresh
End Sub
Private Sub ZRen_Click()
Dim ZRen As New MapObjects2.ZRenderer
Dim f_to_m As Double
f_to_m = 917 / 3000 '將英尺轉(zhuǎn)換為米
With ZRen
.BreakCount = 6
.Break(0) = 1000 * f_to_m
.Break(1) = 2500 * f_to_m
.Break(2) = 3000 * f_to_m
.Break(3) = 3500 * f_to_m
.Break(4) = 4000 * f_to_m
.Break(5) = 4500 * f_to_m
.SymbolType = moPointSymbol
For i = 0 To .BreakCount - 1
.Symbol(i).Color = moGray
.Symbol(i).Style = moTriangleMarker
.Symbol(i).Size = i * 3
Next i
End With
Set Map1.Layers(1).Renderer = ZRen
pictureleg.Picture = LoadPicture(App.Path & "/Zleg.bmp")
Map1.Refresh
End Sub
Dim selRecs As MapObjects2.Recordset
'英尺與米的單位轉(zhuǎn)換常量
Dim f_to_m As Double
Dim m_to_f As Double
Dim text_height As Double
Dim scale_width As Double
Dim theBenEasting As Long
Dim theBenNorthing As Long
Dim i As Integer
Private Sub DrawRecordset(recs As MapObjects2.Recordset)
'顯示被選中的山峰
If Not recs Is Nothing Then
Dim sym As New MapObjects2.Symbol
sym.SymbolType = moPointSymbol
sym.Color = moYellow
sym.Style = moTriangleMarker
sym.Size = 6
Map1.DrawShape recs, sym
End If
End Sub
Private Sub Form_Load()
'初始化
Set selRecs = Nothing
f_to_m = 0.3048037
m_to_f = 3.2808
text_height = 2000
scale_width = 50000
theBenEasting = 216600
theBenNorthing = 771300
Dim dc As New DataConnection
dc.Database = "D:Program FilesESRIMapObjects2SamplesDataScotland"
If Not dc.Connect Then Exit Sub
Dim Scotcoast As New MapObjects2.MapLayer
Scotcoast.GeoDataset = dc.FindGeoDataset("scotcoast")
Scotcoast.Symbol.Color = moLightYellow
Map1.Layers.Add Scotcoast
Dim Mountains As New MapObjects2.MapLayer
Mountains.GeoDataset = dc.FindGeoDataset("mountains")
Mountains.Symbol.Color = moWhite
Mountains.Symbol.Size = 6
Mountains.Symbol.Style = moTriangleMarker
Map1.Layers.Add Mountains
Dim Mountainslp As New MapObjects2.MapLayer
Mountainslp.GeoDataset = dc.FindGeoDataset("mountains")
Mountainslp.Symbol.Size = 0
Map1.Layers.Add Mountainslp
VRen.Value = True
End Sub
Private Sub selection_enable(bool As Boolean)
sel2d.Enabled = bool
sel3d.Enabled = bool
If sel3d.Value Then
ceiling.Enabled = bool
floor.Enabled = bool
End If
End Sub
Public Sub selrect(rect As MapObjects2.Rectangle)
'查詢二維矩形或三維加入收藏 立方體中的山峰
If (sel3d.Value) Then
'如果是三維立方體，則設(shè)置floor屬性和ceiling屬性
rect.floor = floor.Text
rect.ceiling = ceiling.Text
End If
Set selRecs = Map1.Layers(0).SearchShape(rect, moContaining, "")
clue.Caption = selRecs.Count & "個山峰已被選擇"
Map1.TrackingLayer.Refresh True
End Sub
Private Sub Map1_AfterTrackingLayerDraw(ByVal hDC As stdole.OLE_HANDLE)
If selRecs Is Nothing Then
Exit Sub
End If
DrawRecordset selRecs
End Sub
Private Sub Map1_BeforeLayerDraw(ByVal index As Integer, ByVal hDC As stdole.OLE_HANDLE)
If Map1.Extent.Width > scale_width Then
lPlacer.Enabled = False
Map1.Layers(0).Visible = False
Else
lPlacer.Enabled = True
make_LPlacer
Map1.Layers(0).Visible = lPlacer
End If
End Sub
Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Toolbar1.Buttons("zoomin").Value = 1 Then
Map1.Extent = Map1.TrackRectangle
ElseIf Toolbar1.Buttons("zoomout").Value = 1 Then
Dim r As MapObjects2.Rectangle
Set r = Map1.Extent
r.ScaleRectangle 1.5
Map1.Extent = r
ElseIf Toolbar1.Buttons("pan").Value = 1 Then
Map1.Pan
ElseIf Toolbar1.Buttons("rect").Value = 1 Then
Dim rect As MapObjects2.Rectangle
Set rect = Map1.TrackRectangle
If (rect.Width > 0) Then
Call selrect(rect)
End If
End If
End Sub
Private Sub NoRen_Click()
'“無”單選框鼠標(biāo)點擊事件響應(yīng)代碼
If NoRen Then
Map1.Layers(1).Renderer = Nothing
pictureleg.Picture = LoadPicture()
Map1.Refresh
End If
End Sub
Private Sub sel2d_Click()
floor.Enabled = False
ceiling.Enabled = False
MsgBox "將選擇二維立方體內(nèi)的山峰，忽略Z值"
Map1.MousePointer = moCross
Toolbar1.Buttons("rect").Value = 1
End Sub Private Sub make_LPlacer()
Dim lp As New MapObjects2.LabelPlacer
Dim fnt As New StdFont
fnt.Name = "Arial"
fnt.Bold = True
With lp
Set .DefaultSymbol.Font = fnt
.UseDefault = True
.DefaultSymbol.Height = text_height * Map1.Extent.Height / scale_width
.Field = "name"
.DrawBackground = True
End With
Map1.Layers(0).Renderer = lp
End Sub
Private Sub sel3d_Click()
floor.Enabled = True
ceiling.Enabled = True
MsgBox "將選擇三維立方體內(nèi)的山峰，立方體的底部為" & floor & "，頂部為" & ceiling
Map1.MousePointer = moCross
Toolbar1.Buttons("rect").Value = 1
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComCtlLib.Button)
On Error Resume Next
Select Case Button.Key
Case "zoomin"
'應(yīng)做:添加 'zoomin' 按鈕代碼。
Map1.MousePointer = moZoomIn
Call selection_enable(False)
Case "zoomout"
'應(yīng)做:添加 'zoomout' 按鈕代碼。
Map1.MousePointer = moZoomOut
Call selection_enable(False)
Case "pan"
'應(yīng)做:添加 'pan' 按鈕代碼。
Map1.MousePointer = moPan
Call selection_enable(False)
Case "rect"
'應(yīng)做:添加 'arrow' 按鈕代碼。
Map1.MousePointer = moCross
Call selection_enable(False)
Case "globe"
'應(yīng)做:添加 'globe' 按鈕代碼。
Map1.MousePointer = moDefault
Map1.Extent = Map1.FullExtent
End Select
End Sub
Private Sub VRen_Click()
Dim VRen As New MapObjects2.ValueMapRenderer
With VRen
'3種類型的山峰
.ValueCount = 3
.Field = "type"
.SymbolType = moPointSymbol
.Value(0) = "Munro"
.Value(1) = "Corbett"
.Value(2) = "Other"
'設(shè)置每種山峰的顏色
.SymbolType = moPointSymbol
.Symbol(0).Color = moBlue
.Symbol(1).Color = moRed
.Symbol(2).Color = moGreen
'設(shè)置symbol屬性
For i = 0 To .ValueCount - 1
.Symbol(i).Size = 6
.Symbol(i).Style = moTriangleMarker
Next i
End With
'將ValueMapRenderer賦值給Maplayer
Set Map1.Layers(1).Renderer = VRen
pictureleg.Picture = LoadPicture(App.Path + "classleg.bmp")
Map1.Refresh
End Sub
Private Sub ZRen_Click()
Dim ZRen As New MapObjects2.ZRenderer
Dim f_to_m As Double
f_to_m = 917 / 3000 '將英尺轉(zhuǎn)換為米
With ZRen
.BreakCount = 6
.Break(0) = 1000 * f_to_m
.Break(1) = 2500 * f_to_m
.Break(2) = 3000 * f_to_m
.Break(3) = 3500 * f_to_m
.Break(4) = 4000 * f_to_m
.Break(5) = 4500 * f_to_m
.SymbolType = moPointSymbol
For i = 0 To .BreakCount - 1
.Symbol(i).Color = moGray
.Symbol(i).Style = moTriangleMarker
.Symbol(i).Size = i * 3
Next i
End With
Set Map1.Layers(1).Renderer = ZRen
pictureleg.Picture = LoadPicture(App.Path & "/Zleg.bmp")
Map1.Refresh
End Sub