xjtuandrew
路人甲
路人甲
  • 注册日期2003-10-07
  • 发帖数56
  • QQ
  • 铜币264枚
  • 威望0点
  • 贡献值0点
  • 银元0个
阅读:2016回复:4

如何合并多个记录集

楼主#
更多 发布于:2003-10-08 15:49
各位高手,我现在有多个记录集,结构完全相同,如何合并他们呢?同时,相同的记录不再重复。就是说合并后的记录集中没有重复记录,因为我这几个记录集中可能有相同的部分记录。多谢!
喜欢0 评分0
jxfzcgh
外卖仔
外卖仔
  • 注册日期2003-07-26
  • 发帖数69
  • QQ
  • 铜币452枚
  • 威望0点
  • 贡献值0点
  • 银元0个
1楼#
发布于:2003-10-08 18:22
请讲清楚你什么意思:
1)"有很多相同结构的记录"
   同一个shp文件的所有记录当然结构完全相同
2)"相同的记录不再重复"
  一个shp文件为什么要有相同的记录,相同的记录代表图元重复,你为什么会有这种情况
3)"因为我这几个记录集中可能有相同的部分记录"
    你这些记录集是怎么得到的
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15951
  • QQ
  • 铜币25345枚
  • 威望15368点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
2楼#
发布于:2003-10-08 18:29
转贴一个!

希望达到arcview和arcinfo中union操作的功能,但感觉mo中的union命令是把相邻的polygon做了融合,对于那种成十字交*的多边形,用part提取后,得不到非重叠区的polygon,面积和周长都是0,我把我的代码贴上,大家看看哪里有问题,谢谢。

Private Sub menuUnioner_Click()
Dim pRecordset1 As New MapObjects2.Recordset
Dim pRecordset2 As New MapObjects2.Recordset
Dim i As Long, j As Long

'On Error GoTo errHandle:
If mapDisp.Layers.count < 2 Then
MsgBox "少于两个图层,不做整合运算"
Exit Sub
Else
frmSelRecord.Show vbModal
End If

'获取两个记录集
If sLayer1 = "" Or sLayer2 = "" Then Exit Sub
Set pRecordset1 = mapDisp.Layers(sLayer1).Records
Set pRecordset2 = mapDisp.Layers(sLayer2).Records

Dim pPolygon1 As MapObjects2.Polygon
Dim pPolygon2 As MapObjects2.Polygon
Dim pTempPoly As MapObjects2.Polygon
Dim pPolygon3 As MapObjects2.Polygon
Dim pPolygon4 As MapObjects2.Polygon
Dim pUnionShape As MapObjects2.Polygon
Dim pUnionEvent As New MapObjects2.GeoEvent

pRecordset1.MoveFirst
pRecordset2.MoveFirst
Do Until pRecordset1.EOF
Set pPolygon1 = pRecordset1.Fields("shape").value
Do Until pRecordset2.EOF
Set pPolygon2 = pRecordset2.Fields("shape").value
Set pTempPoly = pPolygon1.Intersect(pPolygon2, mapDisp.FullExtent)
If Not pTempPoly Is Nothing Then
i = i + 1
'ReDim Preserve pObject(i)
pObject.Add pTempPoly, CStr(i)

Set pPolygon3 = pPolygon1.Difference(pTempPoly, mapDisp.FullExtent)
If Not pPolygon3 Is Nothing Then
If pPolygon3.Parts.count = 1 Then
i = i + 1
'ReDim Preserve pObject(i)
pObject.Add pPolygon3, CStr(i)
'Set pUnionEvent = mapDisp.TrackingLayer.AddEvent(pPolygon3, 0)
Else
For j = 1 To pPolygon3.Parts.count
i = i + 1
'ReDim Preserve pObject(i)
pObject.Add pPolygon3.Parts(j - 1), CStr(i)
Next j
End If
End If

Set pPolygon4 = pPolygon2.Difference(pTempPoly, mapDisp.FullExtent)
If Not pPolygon4 Is Nothing Then
If pPolygon4.Parts.count = 1 Then
i = i + 1
'ReDim Preserve pObject(i)
pObject.Add pPolygon4, CStr(i)
'Set pUnionEvent = mapDisp.TrackingLayer.AddEvent(pPolygon3, 0)
Else
For j = 1 To pPolygon4.Parts.count
i = i + 1
'ReDim Preserve pObject(i)
pObject.Add pPolygon4.Parts(j - 1), CStr(i)
Next j
End If
End If

End If
DoEvents
pRecordset2.MoveNext
Loop
mapDisp.TrackingLayer.ClearEvents

pRecordset2.MoveFirst
pRecordset1.MoveNext
Loop
Debug.Print pObject.count

Dim aa As Integer
pRecordset1.MoveFirst
pRecordset2.MoveFirst
Do Until pRecordset2.EOF
Set pPolygon2 = pRecordset2.Fields("shape").value
aa = 0
Do Until pRecordset1.EOF
Set pTempPoly = pPolygon2.Intersect(pPolygon1, mapDisp.FullExtent)
If Not pTempPoly Is Nothing Then
aa = 1
Exit Do
Else
pRecordset1.MoveNext
End If
Loop
If aa = 0 Then
i = i + 1
'ReDim Preserve pObject(i)
pObject.Add pPolygon2, CStr(i)
End If
pRecordset2.MoveNext
Loop
Debug.Print pObject.count

'图层名清空
sLayer1 = ""
sLayer2 = ""

If MsgBox("是否生成新的shapefile文件?", vbCritical, Me.Caption) = vbOK Then
Call AnalystExportShp(pObject)
End If
MsgBox "完成", vbInformation, "提示"
mapDisp.Refresh
legMapDisp.LoadLegend True

'对象销毁
If Not pPolygon1 Is Nothing Then Set pPolygon1 = Nothing
If Not pPolygon2 Is Nothing Then Set pPolygon2 = Nothing
If Not pPolygon3 Is Nothing Then Set pPolygon2 = Nothing
If Not pPolygon4 Is Nothing Then Set pPolygon2 = Nothing
If Not pUnionShape Is Nothing Then Set pUnionShape = Nothing
'If Not pUnionEvent Is Nothing Then Set pUnionEvent = Nothing
If Not pRecordset1 Is Nothing Then Set pRecordset1 = Nothing
If Not pRecordset2 Is Nothing Then Set pRecordset2 = Nothing
If Not pTempPoly Is Nothing Then Set pTempPoly = Nothing

Dim k As Long
For k = 1 To pObject.count
pObject.Remove (k - 1)
Next k
Exit Sub

'errHandle:
' MsgBox "发生意外错误", vbInformation, "提示"
' Exit Sub
End Sub


'*****************************************************
'获取要素集数组,循环插入新建的shapefile(polygon)中
'该shapefile文件放在程序文件夹的下的shape文件夹
'传入参数pEvent为shape集合
'*****************************************************
Private Sub AnalystExportShp(pEvent As Collection)
Dim gds As MapObjects2.GeoDataset
Dim sName As String
Dim desc As New MapObjects2.TableDesc
Dim dc As New MapObjects2.DataConnection
Dim lyr As New MapObjects2.MapLayer
Dim lPoly As Long
'Dim pPolygons As New Collection
Dim per As Integer
per = 5

'On Error GoTo errHandle
With CommonDialog1
.DialogTitle = "导出分析结果"
.InitDir = App.path
.Filter = "ESRI Shapefiles (*.shp)|*.shp"
.DefaultExt = ".shp"
.ShowSave
End With

If Len(CommonDialog1.fileName) = 0 Then Exit Sub

dc.Database = CurDir
If Not dc.Connect Then Exit Sub
sName = Left(CommonDialog1.FileTitle, Len(CommonDialog1.FileTitle) - 4)

With desc
.FieldCount = 3 '外加字段3个,名称、面积、周长
.FieldName(0) = "Name"
.FieldName(1) = "Area"
.FieldName(2) = "Perimeter"
.FieldType(0) = moString '地段类型
.FieldType(1) = moDouble
.FieldType(2) = moDouble
.FieldLength(0) = 16 '字段长度
.FieldPrecision(1) = 15 '字段精度
.FieldPrecision(2) = 15
.FieldScale(1) = 1 '小数点位数
.FieldScale(2) = 1
End With

Set gds = dc.AddGeoDataset(sName, moShapeTypePolygon, desc)
If gds Is Nothing Then Exit Sub
Set lyr.GeoDataset = gds
mapDisp.Layers.Add lyr
legMapDisp.LoadLegend True

'进度条控制
Dim lCount As Long
lCount = pEvent.count \ 20
frmProgress.Left = (Screen.Width - frmProgress.Width) / 2
frmProgress.Top = (Screen.Height - frmProgress.Height) / 2
frmProgress.Show
frmProgress.ProgressBar1.Max = pEvent.count + 1
frmProgress.ProgressBar1.Visible = True
frmProgress.ProgressBar1.ZOrder 0


If lyr.Records.Updatable Then
'如果polygon的数目小于20,则进度条按polygon的数据计算
If lCount = 0 Then
frmProgress.ProgressBar1.Min = 1
frmProgress.ProgressBar1.Max = pEvent.count + 1
Else
frmProgress.ProgressBar1.Min = 1
frmProgress.ProgressBar1.Max = 20
End If

For lPoly = 1 To pEvent.count 'recordset数组上下界
With lyr.Records
.AddNew
.Fields("Shape").value = pEvent(lPoly)
.Fields("Name").value = "Poly " & (lPoly)
.Fields("Area").value = pEvent(lPoly).Area //面积和周长赋值就会出问题,因为集合中十字交叉的非公共区要素并没有图形
.Fields("Perimeter").value = pEvent(lPoly).Perimeter
.Update

If lCount = 0 Then
frmProgress.ProgressBar1.value = frmProgress.ProgressBar1.value + 1
Else
If lPoly >= 20 * lCount Then
frmProgress.ProgressBar1.value = frmProgress.ProgressBar1.value
Else
If lPoly Mod lCount <> 0 Then
frmProgress.ProgressBar1.value = frmProgress.ProgressBar1.value
Else
frmProgress.ProgressBar1.value = frmProgress.ProgressBar1.value + 1
per = per + 5
frmProgress.Caption = "创建Shape文件进度:" + str(per) + "%"
End If
End If
End If
End With
DoEvents
Next
' frmProgress.Caption = "创建Shape文件进度:100%"
End If
Unload frmProgress

'对象销毁
Set gds = Nothing
Set desc = Nothing
Set dc = Nothing
Set lyr = Nothing
'Set pPolygons = Nothing

Exit Sub

'errHandle:
' Exit Sub
End Sub

GIS麦田守望者,期待与您交流。
举报 回复(0) 喜欢(0)     评分
xjtuandrew
路人甲
路人甲
  • 注册日期2003-10-07
  • 发帖数56
  • QQ
  • 铜币264枚
  • 威望0点
  • 贡献值0点
  • 银元0个
3楼#
发布于:2003-10-08 19:23
其实我的意思很简单,就是一个shape文件的记录集,我选中了其中的几个部分,并且可能又重叠的,我如何把这些选中的部分合成一个记录集
举报 回复(0) 喜欢(0)     评分
jxfzcgh
外卖仔
外卖仔
  • 注册日期2003-07-26
  • 发帖数69
  • QQ
  • 铜币452枚
  • 威望0点
  • 贡献值0点
  • 银元0个
4楼#
发布于:2003-10-13 17:15
这样啊 ,用recordset.union就可以了吧
举报 回复(0) 喜欢(0)     评分
游客

返回顶部