昨晚写了intersect操作的代码[转帖]

作者cafecat

昨晚写了intersect操作的代码
'intersect操作，针对两个多边形
'********************************
'解释：只取两个层重叠部分，做切割
'由layer传入对象
'pSourcelyr：主图层
'pOverlaylyr：叠加图层
'为了方便，新建层字段全部采用字符串型
'********************************
Public Function Intersect(pSourcelyr As mapobjects2.MapLayer, _
pOverlaylyr As mapobjects2.MapLayer, _
pMap As map) As mapobjects2.MapLayer
On Error GoTo errs:

'判断传入数据合法性
If (pSourcelyr Is Nothing) Or (poverlayerlr Is Nothing) Then
MsgBox "传入的对象为空", vbInformation, "错误提示"
Exit Function
End If

'设置新文件保存路径（以后考虑放到临时文件夹下）
Dim pCommonDialog As CommonDialog
With pCommonDialog
.DialogTitle = "结果保存为"
.InitDir = App.path
.Filter = "ESRI Shapefiles (*.shp)|*.shp"
.DefaultExt = ".shp"
.ShowSave
End With

If Len(pCommonDialog.Filename) = 0 Then
Exit Function
Else
Dim sName As String
sName = Left(pCommonDialog.FileTitle, Len(pCommonDialog.FileTitle) - 4)
End If

'建立数据空间连接
Dim pDataConnect As New mapobjects2.DataConnection
Dim pGeoDataset As mapobjects2.GeoDataset
pDataConnect.Database = CurDir
If Not pGeoDataset.Connect Then Exit Function

'图层对象传入
Dim pSourlyr As New mapobjects2.MapLayer
Dim pOverlylyr As New mapobjects2.MapLayer
Set pSourlyr = pSourcelyr
Set pOverlylyr = pOverlaylyr

'获取两个图层的属性字段，构建新图层的属性表
Dim pTargetDesc As New mapobjects2.TableDesc

Dim pSourrcd As New mapobjects2.Recordset
Dim pTargetrcd As New mapobjects2.Recordset
Set pSourrcd = pSourlyr.Records
Set pTargetrcd = pOverlylyr.Records

Dim pSourfld As mapobjects2.Field
Dim pSourflds As mapobjects2.Fields
Dim pTargetfld As mapobjects2.Field
Dim pTargetflds As mapobjects2.Fields
Set pSourflds = pSourrcd.Fields
Set pTargetflds = pTargetrcd.Fields

Dim I As Integer, iA As Integer, iB As Integer
For Each pSourfld In pSourflds
If pSourfld.Name <> "Area" And pSourfld.Name <> "Perimeter" And pTargetfld.Name <> "Shape" Then
I = I + 1
With pTargetDesc
.FieldCount = I
.FieldName(I) = pSourfld.Name
.FieldType(I) = moString
.FieldLength(I) = 20
End With
End If
Next
iA = I
For Each pTargetfld In pTargetflds
If pTargetfld.Name <> "Area" And pTargetfld.Name <> "Perimeter" And pTargetfld.Name <> "Shape" Then
I = I + 1
With pTargetDesc
.FieldCount = I
.FieldName(I) = pTargetfld.Name
.FieldType(I) = moString
.FieldLength(I) = 20
End With
End If
Next
iB = I
With pTargetDesc '加入shape，area和perimeter字段
.FieldCount = I + 2
.FieldName(I + 1) = "Area"
.FieldType(I + 1) = moString
.FieldLength(I + 1) = 20
.FieldName(I + 2) = "Perimeter"
.FieldType(I + 2) = moString
.FieldLength(I + 2) = 20
End With

'构建新图层,如果pTargetDesc结构错误,则不能创建新图层
Set pGeoDataset = pDataConnect .AddGeoDataset(sName, moPolygon, pTargetDesc)
If pGeoDataset Is Nothing Then
MsgBox "未能创建新文件", vbInformation, "错误提示"
Exit Function
End If

Dim pResultlyr As New mapobjects2.MapLayer
Set pResultlyr.GeoDataset = pGeoDataset
pMap.Layers.Add pResultlyr

'如果该属性表可编辑,则如下操作
If pResultlyr.Records.Updatable Then
Dim pPolygon1 As mapobjects2.Polygon
Dim pPolygon2 As mapobjects2.Polygon
Dim pInterPoly As mapobjects2.Polygon
Dim k As Integer

pSourrcd.MoveFirst
pTargetrcd.MoveFirst
Do Until pSourrcd.EOF
Set pPolygon1 = pSourrcd.Fields("shape").value

Do Until pTargetrcd.EOF
Set pPolygon2 = pTargetrcd.Fields("shape").value
Set pInterPoly = pPolygon1.Intersect(pPolygon2, pMap.FullExtent)
If Not pInterPoly Is Nothing Then
With pResultlyr.Records
.AddNew
.Fields("Shape").value = pInterPoly
.Fields("Area").value = str(pInterPoly.Area)
.Fields("Perimeter").value = str(pInterPoly.Perimeter)
For k = 1 To iA
.Fields(k).value = pSourrcd.Fields(.Fields(k).Name).valueAsString
Next k
For k = iA + 1 To iB
.Fields(k).value = pTargetrcd.Fields(.Fields(k).Name).valueAsString
Next k
End With
End If
pTargetrcd.MoveNext
Loop

pTargetrcd.MoveFirst
pSourrcd.MoveNext
Loop

.Update
End If

pMap.Refresh

'对象销毁
Set pDataConnect = Nothing
Set pGeoDataset = Nothing
Set pSourlyr = Nothing
Set pOverlylyr = Nothing
Set pSourfld = Nothing
Set pSourflds = Nothing
Set pTargetfld = Nothing
Set pTargetflds = Nothing
Set pPolygon1 = Nothing
Set pPolygon2 = Nothing
Set pInterPoly = Nothing
Set pResultlyr = Nothing
Exit Function

errs:
End Function


算法倒不是问题,问题是新文件的建立,如果判断该加入的字段,还有就是后来给新属性表加记录,我这么写,也不知道对不对,请写过的人介绍一下你们的实现方法,谢谢.