Option Explicit
Dim selRecs As MapObjects2.Recordset
'英尺与⽶的单位转换常量
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
'如果是三维⽴⽅体，则设置floor属性和ceiling属性
rect.floor = floor.Text
iling = 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()
'“⽆”单选框⿏标点击事件响应代码
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 "将选择⼆维⽴⽅体内的⼭峰，忽略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 "将选择三维⽴⽅体内的⼭峰，⽴⽅体的底部为" & 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"
'应做：添加 'zoomin' 按钮代码。
Map1.MousePointer = moZoomIn
Call selection_enable(False)
Case "zoomout"
'应做：添加 'zoomout' 按钮代码。
Map1.MousePointer = moZoomOut
Call selection_enable(False)
Case "pan"
'应做：添加 'pan' 按钮代码。
Map1.MousePointer = moPan
Call selection_enable(False)
Case "rect"
'应做：添加 'arrow' 按钮代码。
Map1.MousePointer = moCross
Call selection_enable(False)
Case "globe"
'应做：添加 'globe' 按钮代码。
Map1.MousePointer = moDefault
Map1.Extent = Map1.FullExtent
End Select
End Sub
Private Sub VRen_Click()
Dim VRen As New MapObjects2.ValueMapRenderer
二级VB With VRen
'3种类型的⼭峰
.ValueCount = 3
.Field = "type"
.SymbolType = moPointSymbol
.Value(0) = "Munro"
.Value(1) = "Corbett"
.Value(2) = "Other"
'设置每种⼭峰的颜⾊
.SymbolType = moPointSymbol
.Symbol(0).Color = moBlue
.Symbol(1).Color = moRed
.Symbol(2).Color = moGreen
'设置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 '将英尺转换为⽶
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
版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。
发表评论