最近写的Union功能的代码

做的是完整的切割，和arcview的union结果不相同，我想它是做了容差的判断，我的结果比它的多，但算法是应该没问题的，有兴趣的再改改。
  
  Private Sub menuOverlay_Click()
    If Map1.Layers.Count > 0 Then
    MO_ListLayers.Show vbModal
  End If
  
  If MO_ListLayers.g_sLayerName.Count = 0 Then Exit Sub
  
  MO_Prograss.Show vbModeless
  
  'union主代码
  Dim pRSNew As New MapObjects2.Recordset  '新文件的recordset对象
  Dim pTableDescNew As New MapObjects2.TableDesc  '新文件表结构对象
  Dim i As Integer
  
  Dim sLayerNameFirst As String
  Dim sLayerNameSecond As String
  sLayerNameFirst = MO_ListLayers.g_sLayerName.Item(1)
  sLayerNameSecond = MO_ListLayers.g_sLayerName.Item(2)
  
  Dim pMapLayerFirst As MapObjects2.MapLayer
  Dim pMapLayerSecond As MapObjects2.MapLayer
  Set pMapLayerFirst = Map1.Layers(sLayerNameFirst)
  Set pMapLayerSecond = Map1.Layers(sLayerNameSecond)
  
  If pMapLayerFirst.ShapeType <> moShapeTypePolygon Or pMapLayerSecond.ShapeType <> moShapeTypePolygon Then
    MsgBox "该操作是针对两个多边形图层，请重新选择", vbOKOnly, "操作提示"
    Exit Sub
  End If
  
  Dim pRSFirst As MapObjects2.Recordset
  Dim pRSSecond As MapObjects2.Recordset
  Set pRSFirst = pMapLayerFirst.Records
  Set pRSSecond = pMapLayerSecond.Records
  
  Dim pTableDescFirst As MapObjects2.TableDesc
  Dim pTableDescSecond As MapObjects2.TableDesc
  Set pTableDescFirst = pRSFirst.TableDesc
  Set pTableDescSecond = pRSSecond.TableDesc
  
  '*********************************************
  
  '构建表结构
  Dim pfield As MapObjects2.Field
  For Each pfield In pRSFirst.Fields
    If pfield.Name <> "Shape" And _
       pfield.Name <> "Area" And _
       pfield.Name <> "Perimeter" And _
       pfield.Name <> "FeatureId" And _
       pfield.Name <> "Id" Then
      i = i + 1
    End If
  Next
  For Each pfield In pRSSecond.Fields
    If pfield.Name <> "Shape" And _
       pfield.Name <> "Area" And _
       pfield.Name <> "Perimeter" And _
       pfield.Name <> "FeatureId" And _
       pfield.Name <> "Id" Then
      i = i + 1
    End If
  Next
    
  '定义默认字段
  With pTableDescNew
    .FieldCount = i + 2
    .FieldName(0) = "Area"
    .FieldType(0) = moDouble
    .FieldPrecision(0) = 15
    .FieldScale(0) = 2
    .FieldName(1) = "Perimeter"
    .FieldType(1) = moDouble
    .FieldPrecision(1) = 15
    .FieldScale(1) = 2
  End With
  i = 1
  For Each pfield In pRSFirst.Fields
    If pfield.Name <> "Shape" And _
       pfield.Name <> "Area" And _
       pfield.Name <> "Perimeter" And _
       pfield.Name <> "FeatureId" And _
       pfield.Name <> "Id" Then
      i = i + 1
      With pTableDescNew
        If pfield.Type = moString Then
          .FieldType(i) = moString
          .FieldLength(i) = Len(pfield.Value)
          .FieldName(i) = pfield.Name
        ElseIf pfield.Type = moDouble Then
          .FieldType(i) = moDouble
          .FieldPrecision(i) = 10
          .FieldName(i) = pfield.Name
          .FieldScale(i) = 2
        ElseIf pfield.Type = moLong Then
          .FieldType(i) = moLong
          .FieldName(i) = pfield.Name
        End If
      End With
    End If
  Next
  
  For Each pfield In pRSSecond.Fields
    If pfield.Name <> "Shape" And _
       pfield.Name <> "Area" And _
       pfield.Name <> "Perimeter" And _
       pfield.Name <> "FeatureId" And _
       pfield.Name <> "Id" Then
      i = i + 1
      With pTableDescNew
        If pfield.Type = moString Then
          .FieldType(i) = moString
          .FieldLength(i) = Len(pfield.Value)
          .FieldName(i) = pfield.Name
        ElseIf pfield.Type = moDouble Then
          .FieldType(i) = moDouble
          .FieldName(i) = pfield.Name
          .FieldPrecision(i) = 10
          .FieldScale(i) = 2
        ElseIf pfield.Type = moLong Then
          .FieldType(i) = moLong
          .FieldName(i) = pfield.Name
          .FieldPrecision(i) = 10
        End If
      End With
    End If
  Next
  
  '获取文件名
  Dim sFileName As String
  sFileName = InputBox("请输入新文件名（无后缀）", "创建操作")
  
  '创建shp文件
  Dim pDC As New MapObjects2.DataConnection
  pDC.Database = App.path & "\shape"
  If Not pDC.Connect Then
    MsgBox "无法打开shp创建路径"
    Unload MO_Prograss
    Exit Sub
  End If
  Dim pGeoDB As MapObjects2.GeoDataset
  Set pGeoDB = pDC.AddGeoDataset(sFileName, moShapeTypePolygon, pTableDescNew)
  If pGeoDB Is Nothing Then
    MsgBox "无法创建shp文件"
    Unload MO_Prograss
    Exit Sub
  End If
  
  '加载该文件
  Dim pTempLayer As New MapObjects2.MapLayer
  Set pTempLayer.GeoDataset = pGeoDB
  Map1.Layers.Add pTempLayer
  mo_legend.LoadLegend True
  
  Set pRSNew = pTempLayer.Records
  
  '**********************************************
  '算法生成
  
  Dim pPolygonF As MapObjects2.Polygon
  Dim pPolygonS As MapObjects2.Polygon
  Dim pInterPoly As MapObjects2.Polygon
  Dim pTempPoly As MapObjects2.Polygon
  Dim pRSTemp As MapObjects2.Recordset
  Dim pDiffPoly As MapObjects2.Polygon
  Dim pReservePoly As MapObjects2.Polygon
  Dim pPoints As MapObjects2.points
  Dim pPoly As MapObjects2.Polygon
  
  pRSFirst.MoveFirst
  pRSSecond.MoveFirst
  Do Until pRSFirst.EOF
    Set pPolygonF = pRSFirst.Fields("Shape").Value
    Set pReservePoly = pPolygonF
    
    '第一层，
    'intersect部分
    Set pRSTemp = pMapLayerSecond.SearchShape(pPolygonF, moAreaIntersect, "")
    If Not pRSTemp.EOF Then  '有相交的
      
      pRSTemp.MoveFirst
      pRSNew.AutoFlush = False
      
      Do Until pRSTemp.EOF
        Set pPolygonS = pRSTemp.Fields("Shape").Value
        
        Set pInterPoly = pPolygonF.Intersect(pPolygonS, Map1.FullExtent)
        
        If Not pInterPoly Is Nothing Then
          If pInterPoly.Parts.Count > 1 Then
            For Each pPoints In pInterPoly.Parts
              Set pPoly = New MapObjects2.Polygon
              pPoly.Parts.Add pPoints
              pRSNew.AddNew
              pRSNew.Fields("Shape").Value = pPoly
              
              For Each pfield In pRSTemp.Fields  '第二层的字段
                If pfield.Name <> "Shape" And _
                   pfield.Name <> "Area" And _
                   pfield.Name <> "Perimeter" And _
                   pfield.Name <> "FeatureId" And _
                   pfield.Name <> "Id" Then
                  pRSNew.Fields(pfield.Name).Value = pfield.Value
                End If
              Next
              
              For Each pfield In pRSFirst.Fields  '第一层的字段
                If pfield.Name <> "Shape" And _
                   pfield.Name <> "Area" And _
                   pfield.Name <> "Perimeter" And _
                   pfield.Name <> "FeatureId" And _
                   pfield.Name <> "Id" Then
                  pRSNew.Fields(pfield.Name).Value = pfield.Value
                End If
              Next
              
              pRSNew.Update
              Set pPoints = Nothing
              Set pPoly = Nothing
            Next
          Else
            pRSNew.AddNew
            pRSNew.Fields("Shape").Value = pInterPoly
            
            For Each pfield In pRSTemp.Fields
              If pfield.Name <> "Shape" And _
                 pfield.Name <> "Area" And _
                 pfield.Name <> "Perimeter" And _
                 pfield.Name <> "FeatureId" And _
                 pfield.Name <> "Id" Then
                pRSNew.Fields(pfield.Name).Value = pfield.Value
              End If
            Next
            
            For Each pfield In pRSFirst.Fields
              If pfield.Name <> "Shape" And _
                 pfield.Name <> "Area" And _
                 pfield.Name <> "Perimeter" And _
                 pfield.Name <> "FeatureId" And _
                 pfield.Name <> "Id" Then
                pRSNew.Fields(pfield.Name).Value = pfield.Value
              End If
            Next
            
            pRSNew.Update
            Set pInterPoly = Nothing
          End If
        End If
        
        Set pDiffPoly = pReservePoly.Difference(pPolygonS, Map1.FullExtent)
        If Not pDiffPoly Is Nothing Then
          Set pReservePoly = pDiffPoly
        End If
        
        Set pInterPoly = Nothing
        Set pPolygonS = Nothing
        pRSTemp.MoveNext
      Loop
      Set pRSTemp = Nothing
      
      '将different部分插入数据集，获取本层的字段值
      If Not pDiffPoly Is Nothing Then
        If pDiffPoly.Parts.Count > 1 Then  '如果different部分为多part的
          For Each pPoints In pDiffPoly.Parts
            Set pPoly = New MapObjects2.Polygon
            pPoly.Parts.Add pPoints
            pRSNew.AddNew
            pRSNew.Fields("Shape").Value = pPoly
            For Each pfield In pRSFirst.Fields
              If pfield.Name <> "Shape" And _
                 pfield.Name <> "Area" And _
                 pfield.Name <> "Perimeter" And _
                 pfield.Name <> "FeatureId" And _
                 pfield.Name <> "Id" Then
                pRSNew.Fields(pfield.Name).Value = pfield.Value
              End If
            Next
            pRSNew.Update
            Set pPoints = Nothing
            Set pPoly = Nothing
          Next
        Else
          pRSNew.AddNew
          pRSNew.Fields("Shape").Value = pDiffPoly
          For Each pfield In pRSFirst.Fields
            If pfield.Name <> "Shape" And _
               pfield.Name <> "Area" And _
               pfield.Name <> "Perimeter" And _
               pfield.Name <> "FeatureId" And _
               pfield.Name <> "Id" Then
              pRSNew.Fields(pfield.Name).Value = pfield.Value
            End If
          Next
          pRSNew.Update
        End If
      End If
    
    Else  '该polygon和第二层都不相交
      pRSNew.AddNew
      pRSNew.Fields("Shape").Value = pPolygonF
      For Each pfield In pRSFirst.Fields
        If pfield.Name <> "Shape" And _
           pfield.Name <> "Area" And _
           pfield.Name <> "Perimeter" And _
           pfield.Name <> "FeatureId" And _
           pfield.Name <> "Id" Then
          pRSNew.Fields(pfield.Name).Value = pfield.Value
        End If
      Next
      pRSNew.Update
    End If
    Set pPolygonF = Nothing
    pRSFirst.MoveNext
  Loop
  pRSNew.AutoFlush = True
  
  '获取第二层different部分
  pRSFirst.MoveFirst
  pRSSecond.MoveFirst
  Do Until pRSSecond.EOF
    Set pPolygonF = pRSSecond.Fields("Shape").Value
    Set pRSTemp = pMapLayerFirst.SearchShape(pPolygonF, moAreaIntersect, "")

    If pRSTemp.EOF Then  '如果跟任何第一层的polygon都不交，则取之
      pRSNew.AddNew
      pRSNew.Fields("Shape").Value = pPolygonF
      For Each pfield In pRSSecond.Fields
        If pfield.Name <> "Shape" And _
           pfield.Name <> "Area" And _
           pfield.Name <> "Perimeter" And _
           pfield.Name <> "FeatureId" And _
           pfield.Name <> "Id" Then
          pRSNew.Fields(pfield.Name).Value = pfield.Value
        End If
      Next
      pRSNew.Update
    Else
      pRSTemp.MoveFirst
      Do Until pRSTemp.EOF  '去different部分
        Set pPolygonS = pRSTemp.Fields("Shape").Value
        Set pDiffPoly = pPolygonF.Difference(pPolygonS, Map1.FullExtent)
        If pDiffPoly Is Nothing Then
          Exit Do
        Else
          Set pPolygonF = pDiffPoly
        End If
        pRSTemp.MoveNext
      Loop

      If Not pDiffPoly Is Nothing Then
        If pDiffPoly.Parts.Count > 1 Then  '如果different部分为多part的
          For Each pPoints In pDiffPoly.Parts
            Set pPoly = New MapObjects2.Polygon
            pPoly.Parts.Add pPoints
            pRSNew.AddNew
            pRSNew.Fields("Shape").Value = pPoly
            For Each pfield In pRSFirst.Fields
              If pfield.Name <> "Shape" And _
                 pfield.Name <> "Area" And _
                 pfield.Name <> "Perimeter" And _
                 pfield.Name <> "FeatureId" And _
                 pfield.Name <> "Id" Then
                pRSNew.Fields(pfield.Name).Value = pfield.Value
              End If
            Next
            pRSNew.Update
            Set pPoints = Nothing
            Set pPoly = Nothing
          Next
        Else
          pRSNew.AddNew
          pRSNew.Fields("Shape").Value = pDiffPoly
          For Each pfield In pRSFirst.Fields
            If pfield.Name <> "Shape" And _
              pfield.Name <> "Area" And _
              pfield.Name <> "Perimeter" And _
              pfield.Name <> "FeatureId" And _
              pfield.Name <> "Id" Then
              pRSNew.Fields(pfield.Name).Value = pfield.Value
            End If
          Next
          pRSNew.Update
        End If
      End If
    End If

    Set pRSTemp = Nothing
    pRSSecond.MoveNext
  Loop
  
  pRSNew.MoveFirst
  Dim pPolyNew As MapObjects2.Polygon
  pRSNew.AutoFlush = False
  Do Until pRSNew.EOF
    pRSNew.Edit
    Set pPolyNew = pRSNew.Fields("Shape").Value
    If pPolyNew.Area <= 1# Then
      pRSNew.Delete
      pRSNew.MoveNext
    Else
      pRSNew.Fields("Area").Value = pPolyNew.Area
      pRSNew.Fields("Perimeter").Value = pPolyNew.Perimeter
      pRSNew.Update
      Set pPolyNew = Nothing
      pRSNew.MoveNext
    End If
  Loop
  pRSNew.StopEditing
  pRSNew.AutoFlush = True
  
  MO_Prograss.Animation1.Stop
  Unload MO_Prograss
  
  Set pRSFirst = Nothing
  Set pRSSecond = Nothing
  Set pTableDescFirst = Nothing
  Set pTableDescSecond = Nothing
  Set pGeoDB = Nothing
  Set pDC = Nothing
  Set MO_ListLayers.g_sLayerName = Nothing
  
  Map1.Refresh
  mo_legend.LoadLegend True
  MsgBox "Union操作完成!"
End Sub

很奇怪，第一次创建polygon时写入的面积和周长都不正确
所以把多边形都创建完，重新写了一次面积和周长，过滤掉面积小于1的多边形。

你说的那个readfile的dll代码，我已经找不到了，抱歉了，兄弟

唉，真遗憾，我感觉那东西写得真不错，用起来方便得很

就那几个函数啦，你可以试着写写啦，很多功能都是一点点写的，多来交流

哈哈，还是想麻烦你再找找，让我再慢慢垒，也不容易啊

好久没用，我看到了一定啦！

呵呵，谢谢，企盼...