如何实现在ArcMap上进行测量[代码+说明]

  距离的测量：要实现的是测量两个点之间的距离。用ToolControl实现，选中工具后，在测量的开始点按鼠标左键，鼠标拖动过程中实时画一条从开始点到鼠标当前位置的橡皮线，计算并显示开始点到目标点的距离，释放左键后擦除所画的线和文本。 <br>
<P>l   要点</P>
<P>要实时显示结果，计算过程应该在MouseMove事件中处理。</P>
<P>要绘制橡皮线，必须设置当前绘图模式为esriROPXOrPen。即混合后的颜色取为当前背景色和画笔颜色的“异或”结果。这样在设定了画笔颜色后，在同一位置第二次画同一图形，就会将图形“擦除”，并恢复原来的背景色。</P>
<P>所有的对设备（包括显示器、打印机、内存位图）的绘图操的前后都应分别调用IDisplay的两个方法StartDrawing和EndDrawing。StartDrawing可以准备特定的设备环境，管理本例中要用到的各种Symbols，FinishDrawing完成收尾工作，以保证下一次对StartDrawing的调用不会出错。</P>
<P>l   程序说明</P>
<P>函数UITMeasureDistance_Deactivate是Deactivate属性的处理代码，当工具失去焦点时，清除已创建的对象。过程UITMeasureDistance_MouseDown是MouseDown事件的处理代码，当鼠标键按下时，记录起始点。过程UITMeasureDistance_MouseMove是MouseMove事件的处理代码，鼠标移动过程中测量距离，计算文本显示的角度，以及完成屏幕上橡皮线的绘制。过程UITMeasureDistance_MouseUp是MouseUp事件的处理代码，当释放鼠标键时，擦除刚绘制的图形。函数GetSmashedLine将获得一条IPolyline对象，这条Polyline在要显示文本的地方留下了空白，以防止出现所画线穿过文字的现象。</P>
<P>另外，本例未考虑坐标系的转换，在球面地理坐标系是测量结果为经度差或纬度差。</P>
<P>l   代码</P>
<P>Option Explicit<br>Private m_bInUse        As Boolean<br>Private m_pLineSymbol   As ILineSymbol<br>Private m_pLinePolyline As IPolyline<br>Private m_pTextSymbol   As ITextSymbol<br>Private m_pStartPoint   As IPoint<br>Private m_pTextPoint    As IPoint </P>
<P>Private Function UITMeasureDistance_Deactivate() As Boolean<br>    ' Stop doing operation<br>    Set m_pTextSymbol = Nothing<br>    Set m_pTextPoint = Nothing<br>    Set m_pLinePolyline = Nothing<br>    Set m_pLineSymbol = Nothing<br>    m_bInUse = False<br>    UITMeasureDistance_Deactivate = True<br>End Function </P>
<P>Private Sub UITMeasureDistance_MouseDown(ByVal Button As Long, ByVal Shift As Long, _ByVal X As Long, ByVal Y As Long)   <br>    Dim pMxDocument     As IMxDocument<br>    Dim pActiveView     As IActiveView<br>    m_bInUse = True<br>    Set pMxDocument = ThisDocument<br>    Set pActiveView = pMxDocument.FocusMap<br>    ' Get point to measure distance from<br>    Set m_pStartPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)<br>End Sub </P>
<P>Private Sub UITMeasureDistance_MouseMove(ByVal Button As Long, ByVal Shift As Long, _ByVal X As Long, ByVal Y As Long)<br>    Dim pMxDocument         As IMxDocument<br>    Dim pActiveView         As IActiveView<br>    Dim bFirstTime          As Boolean<br>    Dim pPoint              As IPoint<br>    Dim pRGBColor           As IRgbColor<br>    Dim pSymbol             As ISymbol<br>    Dim pFont               As IFontDisp<br>    Dim pLine               As ILine<br>    Dim dAngle              As Double<br>    Dim dDeltaX             As Double<br>    Dim dDeltaY             As Double<br>    Dim dDistance           As Double<br>    Dim pPolyLine           As IPolyline<br>    Dim pSegmentCollection  As ISegmentCollection<br>    On Error GoTo ErrorHandler<br>    If (Not m_bInUse) Then<br>        Exit Sub<br>    End If<br>    Set pMxDocument = ThisDocument<br>    Set pActiveView = pMxDocument.FocusMap           </P>
<P>    If (m_pLineSymbol Is Nothing) Then<br>        bFirstTime = True<br>    End If<br>    ' Get current point<br>    Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(X, Y)<br>    pActiveView.ScreenDisplay.StartDrawing pActiveView.ScreenDisplay.hDC, -1</P>
<P>    If bFirstTime Then<br>        ' Set Line Symbol<br>        Set m_pLineSymbol = New SimpleLineSymbol<br>        m_pLineSymbol.Width = 2<br>        Set pRGBColor = New RgbColor<br>        With pRGBColor<br>            .Red = 222<br>            .Green = 222<br>            .Blue = 222<br>        End With<br>        m_pLineSymbol.Color = pRGBColor<br>        Set pSymbol = m_pLineSymbol<br>        pSymbol.ROP2 = esriROPXOrPen<br>        ' Set Text Symbol<br>        Set m_pTextSymbol = New TextSymbol<br>        m_pTextSymbol.HorizontalAlignment = esriTHACenter<br>        m_pTextSymbol.VerticalAlignment = esriTVACenter<br>        m_pTextSymbol.Size = 16<br>        Set pSymbol = m_pTextSymbol<br>        Set pFont = m_pTextSymbol.Font<br>        pFont.Name = "Arial"<br>        pSymbol.ROP2 = esriROPXOrPen<br>        ' Create point to draw text in<br>        Set m_pTextPoint = New Point<br>    Else<br>        ' Use existing symbols and draw existing text and polyline<br>        pActiveView.ScreenDisplay.SetSymbol m_pTextSymbol<br>        pActiveView.ScreenDisplay.DrawText m_pTextPoint, m_pTextSymbol.Text<br>        pActiveView.ScreenDisplay.SetSymbol m_pLineSymbol<br>        If (m_pLinePolyline.Length > 0) Then<br>            pActiveView.ScreenDisplay.DrawPolyline m_pLinePolyline<br>        End If<br>    End If<br>    ' Get line between from and to points, and dAngle for text<br>    Set pLine = New esriCore.Line<br>    pLine.PutCoords m_pStartPoint, pPoint<br>    dAngle = pLine.angle<br>    dAngle = dAngle * (180# / 3.14159)<br>    If ((dAngle > 90#) And (dAngle < 180#)) Then<br>        dAngle = dAngle + 180#<br>    ElseIf ((dAngle < 0#) And (dAngle < -90#)) Then<br>        dAngle = dAngle - 180#<br>    ElseIf ((dAngle < -90#) And (dAngle > -180)) Then<br>        dAngle = dAngle - 180#<br>    ElseIf (dAngle > 180) Then<br>        dAngle = dAngle - 180#<br>    End If<br>    ' For drawing text, get text(dDistance), dAngle, and point<br>    dDeltaX = pPoint.X - m_pStartPoint.X<br>    dDeltaY = pPoint.Y - m_pStartPoint.Y<br>    m_pTextPoint.X = m_pStartPoint.X + dDeltaX / 2#<br>    m_pTextPoint.Y = m_pStartPoint.Y + dDeltaY / 2#<br>    m_pTextSymbol.angle = dAngle<br>    dDistance = Round(pLine.Length, 3)<br>    m_pTextSymbol.Text = "[" ; dDistance ; "]"<br>    ' Draw text<br>    pActiveView.ScreenDisplay.SetSymbol m_pTextSymbol<br>    pActiveView.ScreenDisplay.DrawText m_pTextPoint, m_pTextSymbol.Text<br>    ' Get polyline with blank space for text<br>    Set pPolyLine = New Polyline<br>    Set pSegmentCollection = pPolyLine<br>    pSegmentCollection.AddSegment pLine<br>    Set m_pLinePolyline = GetSmashedLine(pActiveView.ScreenDisplay, m_pTextSymbol, _m_pTextPoint, pPolyLine)<br>    ' Draw polyline<br>    pActiveView.ScreenDisplay.SetSymbol m_pLineSymbol<br>    If (m_pLinePolyline.Length > 0) Then<br>        pActiveView.ScreenDisplay.DrawPolyline m_pLinePolyline<br>    End If<br>    pActiveView.ScreenDisplay.FinishDrawing<br>    Exit Sub<br>ErrorHandler:<br>    MsgBox Err.Description<br>End Sub</P>
<P>Private Sub UITMeasureDistance_MouseUp(ByVal Button As Long, ByVal Shift As Long, _ByVal X As Long, ByVal Y As Long)<br>    Dim pMxDocument     As IMxDocument<br>    Dim pActiveView     As IActiveView<br>    On Error GoTo ErrorHandler<br>    If (Not m_bInUse) Then<br>        Exit Sub<br>    End If<br>    m_bInUse = False<br>    If (m_pLineSymbol Is Nothing) Then<br>        Exit Sub<br>    End If<br>    Set pMxDocument = ThisDocument<br>    Set pActiveView = pMxDocument.FocusMap<br>    'Draw measure line and text<br>    pActiveView.ScreenDisplay.StartDrawing pActiveView.ScreenDisplay.hDC, -1<br>    pActiveView.ScreenDisplay.SetSymbol m_pTextSymbol<br>    pActiveView.ScreenDisplay.DrawText m_pTextPoint, m_pTextSymbol.Text<br>    pActiveView.ScreenDisplay.SetSymbol m_pLineSymbol<br>     If (m_pLinePolyline.Length > 0) Then<br>        pActiveView.ScreenDisplay.DrawPolyline m_pLinePolyline<br>    End If<br>    pActiveView.ScreenDisplay.FinishDrawing<br>    Set m_pTextSymbol = Nothing<br>    Set m_pTextPoint = Nothing<br>    Set m_pLinePolyline = Nothing<br>    Set m_pLineSymbol = Nothing<br>    Exit Sub<br>ErrorHandler:<br>    MsgBox Err.Description<br>End Sub </P>
<P>Private Function GetSmashedLine(pDisplay As IScreenDisplay, pTextSymbol As ISymbol, _pPoint As IPoint, pPolyLine As IPolyline) As IPolyline<br>    ' Returns a Polyline with a blank space for the text to go in<br>    Dim pSmashed                As IPolyline<br>    Dim pBoundary               As IPolygon<br>    Dim pTopologicalOperator    As ITopologicalOperator<br>    Dim pIntersect              As IPolyline<br>    On Error GoTo ErrorHandler<br>    Set pBoundary = New Polygon<br>    pTextSymbol.QueryBoundary pDisplay.hDC, pDisplay.DisplayTransformation, pPoint, pBoundary<br>    Set pTopologicalOperator = pBoundary<br>    Set pIntersect = pTopologicalOperator.Intersect(pPolyLine, esriGeometry1Dimension)<br>    Set pTopologicalOperator = pPolyLine<br>    Set GetSmashedLine = pTopologicalOperator.Difference(pIntersect)<br>    Exit Function<br>ErrorHandler:<br>    MsgBox Err.Description<br>End Function</P>
<P>本例要实现的是如何在ArcMap上测量一个Polygon的面积。</P>
<P>l   要点</P>
<P>首先用IRubberBand.TrackNew方法在ArcMap上画出一个Polygon，然后由这个Polygon获得一个IArea的实例，最后使用IArea.Area方法计算出这个Polygon的面积。</P>
<P>主要用到IRubberBand接口，IPolygon接口和IArea接口。</P>
<P>l   程序说明</P>
<P>函数DrawPolygon实现在ArcMap上画一个Polygon。</P>
<P>函数MeasurePolygon实现测量pPolygon的面积。</P>
<P>l   代码</P>
<P>Private Function DrawPolygon() As IPolygon<br>    Dim pMxDocument             As IMxDocument<br>    Dim pActiveView             As IActiveView<br>    Dim pSimpleFillS            As ISimpleFillSymbol<br>    Dim pRgbColor               As IRgbColor<br>    Dim pRubberBand             As IRubberBand<br>    Dim pPolygon                As IPolygon<br>    On Error GoTo ErrorHandler:<br>    Set pMxDocument = ThisDocument<br>    Set pActiveView = pMxDocument.ActiveView<br>    Set pSimpleFillS = New SimpleFillSymbol<br>    Set pRgbColor = New RgbColor<br>    pRgbColor.Red = 255<br>    pSimpleFillS.Color = pRgbColor<br>    Set pRubberBand = New esriCore.RubberPolygon<br>    Set pPolygon = pRubberBand.TrackNew(pActiveView.ScreenDisplay, pSimpleFillS)<br>    With pActiveView.ScreenDisplay<br>        .StartDrawing pActiveView.ScreenDisplay.hDC, esriNoScreenCache<br>        .SetSymbol pSimpleFillS<br>        .DrawPolygon pPolygon<br>        .FinishDrawing<br>    End With<br>    Set DrawPolygon = pPolygon<br>    Exit Function<br>ErrorHandler:<br>    MsgBox Err.Desciption<br>End Function </P>
<P>Private Function MeasurePolygon(pPolygon As IPolygon) As Double<br>    Dim pArea                   As IArea<br>On Error GoTo ErrorHandler:<br>    Set pArea = pPolygon<br>    MeasurePolygon = Abs(pArea.Area())<br>    Exit Function<br>ErrorHandler:<br>    MsgBox Err.Desciption<br>End Function </P>
<P>Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, _ByVal x As Long, ByVal y As Long)   <br>    Dim pPolygon                As IPolygon<br>    Dim dArea                   As Double<br>On Error GoTo ErrorHandler:<br>    Set pPolygon = DrawPolygon()<br>    dArea = MeasurePolygon(pPolygon)<br>    MsgBox "面积为：" ; dArea<br>    Exit Sub<br>ErrorHandler:<br>    MsgBox Err.Desciption<br>End Sub</P>

<P>有没有globe里面的量算，介绍一下方法？</P>

多谢！整理的这么精细，有收藏价值哦！呵呵！<img src="images/post/smile/dvbbs/em08.gif" /><img src="images/post/smile/dvbbs/em08.gif" />