|
|
技术资料：自定义选择与自动滚屏
以下代码创建选择工具（框选、圈选、多边形选择）而不使用mapx标准的tool，同时实现自动滚屏（效果不太好）。
Dim pnt101 As New Point
Dim pnts103 As New Points
Dim lyr As Layer
Private Sub Command1_Click()
Map1.CurrentTool = 101
End Sub
Private Sub Command2_Click()
Map1.CurrentTool = 102
End Sub
Private Sub Command3_Click()
Map1.CurrentTool = 103
End Sub
Private Sub Form_Load()
'init lyr and the first point
pnt101.Set 0, 0
Set lyr = Map1.Layers.AddUserDrawLayer("DrawLyr", 1)
Map1.Layers.CreateLayer ("Temp")
Map1.Layers.Item("temp").Editable = True
Set Map1.Layers.InsertionLayer = Map1.Layers.Item("temp")
Map1.CreateCustomTool 101, miToolTypePoint, 2 'rect tool
Map1.CreateCustomTool 102, miToolTypePoint, 2 'radius tool
Map1.CreateCustomTool 103, miToolTypePoint, 2 'poly tool
End Sub
Private Sub Map1_DblClick()
If Map1.CurrentTool = 103 And pnts103.Count > 1 Then
Set ftr = Map1.FeatureFactory.CreateRegion(pnts103)
ftr.Attach Map1
Set ftr = Map1.Layers.Item("temp").AddFeature(ftr)
Map1.Layers.Item("Us Capitals").Selection.ClearSelection
Map1.Layers.Item("US Capitals").Selection.SelectByRegion Map1.Layers.Item("temp"), ftr, miSelectionNew
pnts103.RemoveAll
Map1.Layers.Item("temp").DeleteFeature ftr
End If
End Sub
Private Sub Map1_ToolUsed(ByVal ToolNum As Integer, ByVal X1 As Double, ByVal Y1 As Double, ByVal X2 As Double, ByVal Y2 As Double, ByVal Distance As Double, ByVal Shift As Boolean, ByVal Ctrl As Boolean, EnableDefault As Boolean)
Dim ftrs As Features
Dim rect As New Rectangle
If ToolNum = 101 Then
If pnt101.X = 0 And pnt101.Y = 0 Then
pnt101.Set X1, Y1
Else
rect.Set X1, Y1, pnt101.X, pnt101.Y
Set ftrs = Map1.Layers.Item("US Capitals").SearchWithinRectangle(rect, miSearchTypePartiallyWithin)
Map1.Layers.Item("Us Capitals").Selection.ClearSelection
Map1.Layers.Item("Us Capitals").Selection.Add ftrs
pnt101.Set 0, 0
End If
End If
If ToolNum = 102 Then
If pnt101.X = 0 And pnt101.Y = 0 Then
pnt101.Set X1, Y1
Else
Dim dist As Double
dist = Map1.Distance(X1, Y1, pnt101.X, pnt101.Y)
Set ftrs = Map1.Layers.Item("US Capitals").SearchWithinDistance(pnt101, dist, Map1.MapUnit, miSearchTypePartiallyWithin)
Map1.Layers.Item("Us Capitals").Selection.ClearSelection
Map1.Layers.Item("Us Capitals").Selection.Add ftrs
pnt101.Set 0, 0
End If
End If
If ToolNum = 103 Then
pnts103.AddXY X1, Y1
End If
End Sub
Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If X > Map1.MapScreenWidth - 10 Then
Map1.CenterX = Map1.CenterX + 0.5
Else
If X < 10 Then
Map1.CenterX = Map1.CenterX - 0.5
Else
If Y > Map1.MapScreenHeight - 10 Then
Map1.CenterY = Map1.CenterY - 0.5
Else
If Y < 10 Then
Map1.CenterY = Map1.CenterY + 0.5
End If
End If
End If
End If
End Sub |
|
雷达卡
.gif)
发表于 2009-11-15 19:24
提升卡
沉默卡
喧嚣卡
变色卡
抢沙发
显身卡
发表于 2021-12-19 14:54
