如何通过鼠标移动图形

本例主要通过引用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