阅读:957回复:0
请各位帮忙看看有关捕捉点画多边形的程序
<P>我做了一个捕捉点的函数,但用于画多边形时有问题:如果是第二个点,鼠标移动时捕捉到点,就出现和第一点的连线,不会随鼠标移动消失,直到捕捉到另外一点才变为第一点和另一点的连线。如果不用捕捉功能,画多边形是正确的。</P>
<P>画多边形用的是INewPolygonFeedback</P> <P>Private Sub MapControl1_OnMouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long, ByVal mapX As Double, ByVal mapY As Double)</P> <P> Dim pPoint As esricore.IPoint</P> <P> Set pPoint = New Point<BR> pPoint.PutCoords mapX, mapY</P> <P>If (Not m_bToolInUse) Then</P> <P> m_bToolInUse = True</P> <P> Set m_pFeedback = New esricore.NewPolygonFeedback<BR> Set pPolyFeed = m_pFeedback<BR> If gIsSnaping And (Not pSnapPoint Is Nothing) Then<BR> pPolyFeed.Start pSnapPoint<BR> Else<BR> pPolyFeed.Start pPoint<BR> End If</P> <P> If (Not m_pFeedback Is Nothing) Then Set m_pFeedback.Display = pActiveView.ScreenDisplay</P> <P>else</P> <P>If (TypeOf m_pFeedback Is INewPolygonFeedback) Then<BR> Set pPolyFeed = m_pFeedback</P> <P> pPolyFeed.AddPoint pPoint</P> <P>end if</P> <P>end if</P> <P>end sub</P> <P>Private Sub MapControl1_OnMouseMove(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long, ByVal mapX As Double, ByVal mapY As Double)<BR>Dim pPoint As esricore.IPoint</P> <P> Set pPoint = New Point<BR> pPoint.PutCoords mapX, mapY<BR> <BR> ''*****snap point<BR> If gIsSnaping Then<BR> If m_CurLayer Is Nothing Then<BR> Exit Sub<BR> End If<BR> Set pSnapPoint = GetSnapPoint(pPoint)'如果注释掉画多边形是正确的<BR> End If</P> <P>If (Not m_pFeedback Is Nothing) Then<BR> m_pFeedback.MoveTo pPoint<BR> Set m_pPoint = pPoint<BR>End If</P> <P>end sub</P> <P>Function GetSnapPoint(ByVal pPoint As esricore.IPoint) As IPoint<BR> <BR> Dim pOutPoint As IPoint<BR> Dim pFeature As esricore.IFeature<BR> Dim searchRadius As Double<BR> <BR> Set gSnapPoint = Nothing<BR> searchRadius = wjh_ConvertPixelsToMapUnits(MapControl1.Map, 7)<BR> <BR> '创建矩形来搜索相交feature<BR> Dim pEnvelope As IEnvelope<BR> Set pEnvelope = New Envelope<BR> pEnvelope.XMin = pPoint.x - 5<BR> pEnvelope.XMax = pPoint.x + 5<BR> pEnvelope.YMin = pPoint.y - 5<BR> pEnvelope.YMax = pPoint.y + 5<BR> <BR> Dim pSpatialFilter As ISpatialFilter<BR> Set pSpatialFilter = New SpatialFilter<BR> pSpatialFilter.SpatialRel = esriSpatialRelIntersects<BR> pSpatialFilter.GeometryField = "shape"<BR> Set pSpatialFilter.Geometry = pEnvelope<BR> <BR> '只对当前层进行搜索<BR> Dim pFeatureLayer As IFeatureLayer<BR> Set pFeatureLayer = m_CurLayer 'MapControl1.Map.Layer(0)<BR> Dim pFeatureCursor As IFeatureCursor<BR> Set pFeatureCursor = pFeatureLayer.Search(pSpatialFilter, False)<BR> <BR> If Not pFeatureCursor Is Nothing Then<BR> Set pFeature = pFeatureCursor.NextFeature<BR> <BR> '得到最近节点<BR> If Not pFeature Is Nothing Then<BR> Dim pMultiPt As IMultipoint<BR> Dim pPtCol As IPointCollection<BR> Dim pOnePtCol As IPointCollection<BR> Dim pNewPtCol As IPointCollection<BR> <BR> Set pOnePtCol = pFeature.ShapeCopy<BR> Set pMultiPt = New Multipoint<BR> Set pPtCol = pMultiPt<BR> pPtCol.AddPointCollection pOnePtCol<BR> <BR> '把所有相交的feature的节点合并为一个multipoint<BR> Set pFeature = pFeatureCursor.NextFeature<BR> Do While Not pFeature Is Nothing<BR> Set pNewPtCol = pFeature.ShapeCopy<BR> pPtCol.AddPointCollection pNewPtCol<BR> Set pFeature = pFeatureCursor.NextFeature<BR> Loop</P> <P> Dim pTop As ITopologicalOperator<BR> <BR> Set pTop = pMultiPt</P> <P> Dim pProximityOperator As IProximityOperator<BR> Set pProximityOperator = pTop<BR> '得到最近节点<BR> Set pOutPoint = pProximityOperator.ReturnNearestPoint(pPoint, 0)<BR> <BR> If Not pOutPoint Is Nothing Then<BR> 'MapControl1.FlashShape pOutPoint, 3, 300<BR> '判断最近节点是否在设定范围内<BR> Set pProximityOperator = pOutPoint<BR> If pProximityOperator.ReturnDistance(pPoint) <= searchRadius Then<BR> Set gSnapPoint = pOutPoint<BR> frmMain.MapControl1.Refresh esriViewForeground<BR> End If<BR> End If<BR> End If<BR> End If<BR> Set GetSnapPoint = pOutPoint<BR> <BR>End Function</P> <P>后来我发现是刷新的问题,把frmMain.MapControl1.Refresh esriViewForeground这句注释掉就好了,只是刷新的有点慢</P> <P>但没有这句话又无法刷新从而画出捕捉点的标志,怎么办啊?</P> |
|