[分享]求多边形与多个地区相交面积

<P>这是我根据薛伟书中的例子改编的.</P>
<P>Option Explicit
Dim resultShape() As MapObjects2.Polygon
Dim recSelection() As MapObjects2.Recordset
Dim rect As MapObjects2.Polygon
Dim fld As MapObjects2.Field
Dim recs As New MapObjects2.Recordset
Dim I As Integer</P>
<P>
'把查找的区域用黄色显示，找到区域用红色显示；
Private Sub Map1_AfterLayerDraw(ByVal index As Integer, ByVal canceled As Boolean, ByVal hDC As stdole.OLE_HANDLE)
  Dim sym() As New MapObjects2.Symbol
  Dim sym1 As New MapObjects2.Symbol
  Dim Ri As Integer
    
  If Not rect Is Nothing Then
    sym1.Color = moYellow
    Map1.DrawShape rect, sym1
  End If
  
  For Ri = 1 To I
  ReDim sym(I) As New MapObjects2.Symbol
    If Not resultShape(Ri) Is Nothing Then
      sym(Ri).Color = moRed
      Map1.DrawShape resultShape(Ri), sym(Ri)
    End If
  Next Ri
End Sub</P>
<P>
Private Sub Form_Load()
  'DrawLayer
  Label1.Caption = "在地图上画多边形。"
End Sub</P>
<P>Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
  Dim Am As Single
  Const Ak = 1000
  Dim intersectShape() As MapObjects2.Polygon
  Dim strExpression As String
  Dim Ri As Integer
  I = 0
   Set recs = Form1.Map1.Layers.Item(0).Records
     Do While Not recs.EOF
    
        I = I + 1
         recs.MoveNext
        
        Loop
        
  Set rect = Map1.TrackPolygon
  Am = 0
  ReDim resultShape(I) As MapObjects2.Polygon
  ReDim recSelection(I) As MapObjects2.Recordset
  ReDim intersectShape(I) As MapObjects2.Polygon
  For Ri = 1 To I
    strExpression = "FeatureId = " ; Ri
    
    Set recSelection(Ri) = Map1.Layers(0).SearchExpression(strExpression)
    Set intersectShape(Ri) = recSelection(Ri).Fields("Shape").Value
    Set resultShape(Ri) = rect.Intersect(intersectShape(Ri))
    If Not resultShape(Ri) Is Nothing Then
      Am = resultShape(Ri).Area + Am
    End If
  Next Ri
 
  If Am < 0.001 Then
    Label1.Caption = "没有相交。"
  Else
    Label1.Caption = "相交面积＝" ; Format(Am * Ak, "0.00") ; "平方公里。"
  End If
  
  Map1.Refresh
End Sub</P>
<P>
 </P>

<P><img src="images/post/smile/dvbbs/em01.gif" /><img src="images/post/smile/dvbbs/em02.gif" /></P><P>你得到的面积的结果正确吗？</P>

<P>计算结果与下面代码得到的数值接近.</P><P> Set shp = recs.Fields("Shape").Value
 Area = shp.Area</P><P>但是这个shape字段在表里怎么看不到?</P>

<P>Set shp = recs.Fields("Shape").Value
Area = shp.Area  </P><P>得出的面积是很准确的，建议使用这个方法计算面积</P>