免费视频|新人指南|投诉删帖|广告合作|地信网APP下载

查看: 1898|回复: 2
收起左侧

技术资料:自定义选择与自动滚屏

[复制链接]

2072

主题

100000万

铜板

363

好友

地信专家组

每一次的分离都是为了下一次的相聚

Rank: 14Rank: 14Rank: 14Rank: 14

积分
17612

精华勋章宣传勋章爱心勋章组织勋章地信元老灌水勋章荣誉会员勋章活跃勋章贡献勋章

发表于 2009-11-15 19:24 | 显示全部楼层 |阅读模式
技术资料:自定义选择与自动滚屏
以下代码创建选择工具(框选、圈选、多边形选择)而不使用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

2

主题

3万

铜板

7

好友

钻石会员

Rank: 26Rank: 26Rank: 26Rank: 26Rank: 26Rank: 26Rank: 26

积分
5715
发表于 2021-12-19 14:54 | 显示全部楼层
谢谢分享
回复

使用道具 举报

0

主题

2万

铜板

1

好友

资深会员

Rank: 18Rank: 18Rank: 18Rank: 18Rank: 18

积分
3421
发表于 2022-1-4 09:41 | 显示全部楼层
自动滚屏
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

在线客服
快速回复 返回顶部 返回列表