阅读:1227回复:2
自定义选择与自动滚屏[转载]以下代码创建选择工具(框选、圈选、多边形选择)而不使用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 |
|
|