本例主要通过引用IMoveLineFeedback和IMovePolygonFeedback两个接口实现对地图中的Polyline和Polygon的移动。
l要点
对于类型为Polygon的Feature,本例使用接口IMovePolygonFeedback的Start和Stop方法来移动选定的
Feature。其他类型的Feature类似,只需相应地改变接口类型即可。
l程序说明
在工具条上设置一个ToolButton,通过响应该Button的MouseDown( ),MouseMove( ),MouseUp( )事件来实现对图形的移动。本例只列举了Polyline和Polygon两种类型的图形,其他类型的图形可类似操作。
l代码
Dim m_pFeature As IFeature
Dim m_pMxDocument As IMxDocument Dim m_pDisplayFeedback As IDisplayFeedback Dim m_pScreenDisplay As IScreenDisplay Dim m_pMouseCursor As IMouseCursor
Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _
ByVal x As Long, ByVal y As Long) Dim pGeometry As IGeometry Dim pSelectionSet As ISelectionSet Dim pFeatureLayer As IFeatureLayer Dim pFeatureCursor As IFeatureCursor Dim pSpatialFilter As ISpatialFilter Dim pPoint As IPoint Dim pEnvelope As IEnvelope Dim index As Integer On Error GoTo ErrorHandler Set m_pMxDocument = ThisDocument Set m_pScreenDisplay = m_pMxDocument.ActiveView.ScreenDisplay If m_pMxDocument.FocusMap.LayerCount = 0 Then Exit Sub '得到鼠标点击的起点坐标 Set pPoint = m_pScreenDisplay.DisplayTransformation.ToMapPoint(x, y) ' 得到当前鼠标位置的 Envelope Set pGeometry = m_pMxDocument.CurrentLocation.Envelope Set pSpatialFilter = New SpatialFilter Set pEnvelope = pGeometry.Envelope ' 扩大 Envelope 的范围便于搜索 pEnvelope.Expand 0.2, 0.2, False ' 设置空间检索的条件 With pSpatialFilter Set .Geometry = pEnvelope .GeometryField = "SHAPE" .SpatialRel = esriSpatialRelIntersects End With ' 在当前 Map 的所有 FeatureLayer 中查找所要移动的图形 Dim i As Integer i = 0 index = m_pMxDocument.FocusMap.LayerCount Do While i < index Set pFeatureLayer = m_pMxDocument.FocusMap.Layer(i) Set pFeatureCursor = pFeatureLayer.FeatureClass.Search(pSpatialFilter, True) Set m_pFeature = pFeatureCursor.NextFeature If Not m_pFeature Is Nothing Then Exit Do Else i = i + 1 End If Loop If m_pFeature Is Nothing Then Exit Sub '针对不同的Feature类型调用不同的接口进行操作 Select Case m_pFeature.Shape.GeometryType ' 若 Feature 类型为 Polyline Case 3: Set m_pDisplayFeedback = New MoveLineFeedback Set m_pDisplayFeedback.Display = m_pScreenDisplay Dim pMoveLineF As IMoveLineFeedback Set pMoveLineF = m_pDisplayFeedback pMoveLineF.Start m_pFeature.Shape, pPoint ' 若 Feature 类型为 Polygon Case 4: Set m_pDisplayFeedback = New MovePolygonFeedback Set m_pDisplayFeedback.Display = m_pScreenDisplay Dim pMovePolygonF As IMovePolygonFeedback Set pMovePolygonF = m_pDisplayFeedback pMovePolygonF.Start m_pFeature.Shape, pPoint '若为其他类型,本例则省略,不进行操作 Case Else MsgBox "Other SHP Type" Set m_pFeature = Nothing Set m_pScreenDisplay = Nothing Exit Sub End Select m_pMxDocument.ActiveView.Refresh '设置鼠标外观 Set m_pMouseCursor = New MouseCursor m_pMouseCursor.SetCursor 5 Exit Sub ErrorHandler: MsgBox Err.Description End Sub
Private Sub UIToolControl1_MouseMove(ByVal button As Long, ByVal shift As Long, _
ByVal x As Long, ByVal y As Long) On Error GoTo ErrorHandler If Not m_pDisplayFeedback Is Nothing Then Dim pPoint As IPoint ' 得到鼠标点击位置在地图上的坐标 Set pPoint = m_pScreenDisplay.DisplayTransformation.ToMapPoint(x, y) m_pDisplayFeedback.MoveTo pPoint End If Exit Sub ErrorHandler: MsgBox Err.Description End Sub
Private Sub UIToolControl1_MouseUp(ByVal button As Long, ByVal shift As Long, _ ByVal x As Long, ByVal y As Long) Dim pGeometry As IGeometry On Error GoTo ErrorHandler '检查是否存在一个元素 If Not m_pFeature Is Nothing Then '检测此元素的类型 Select Case m_pFeature.Shape.GeometryType Case 3: Dim pMoveLineF As IMoveLineFeedback Set pMoveLineF = m_pDisplayFeedback Set pGeometry = pMoveLineF.Stop Case 4: Dim pMovePolygonF As IMovePolygonFeedback Set pMovePolygonF = m_pDisplayFeedback Set pGeometry = pMovePolygonF.Stop End Select ' 更新元素 Set m_pFeature.Shape = pGeometry m_pFeature.Store Set m_pDisplayFeedback = Nothing m_pMxDocument.ActiveView.Refresh '将鼠标外观还原 Set m_pMouseCursor = New MouseCursor m_pMouseCursor.SetCursor 0 End If Exit Sub ErrorHandler: MsgBox Err.Description End Sub |