公益林小班與林地一張圖小班融合后碎片處理思路_肖玲_20150421

1、公益林小班與林地一張圖小班融合后碎片公益林小班與林地一張圖小班融合后碎片 處理思路處理思路 肖玲肖玲 2015.1.122015.1.12 1總體流程圖總體流程圖 公益林小班 面 Dissolve （按森林類別、事權等級、林地 所有權、林木所有權、國家級公 益林保護等級、工程類別、 sum（兌現面積） 公益林小班 面 _Dissolve 林地年度變 更小班面 Union 林地年度變 更小班面 _union Explode 林地年度變更小班面_union圖層增加 以下字段： DJH、maxX、minX、maxY、minY、 area_envelope、area_percent、 isSelect

2、ed 計算林地年度變更小班面_union圖層 圖斑DJH、maxX、minX、maxY、minY、 area_envelope、area_percent Area_percent 0.3 isSelected = 1是 isSelected = Null 否 林地年度變更小班面增加以下字段： DJH、maxX、minX、maxY、minY、 area_envelope、area_percent、 isSelected 計算林地年度變更小班面圖斑DJH、 maxX、minX、maxY、minY、 area_envelope、area_percent 篩選 Area_percent0 then s

3、erial()=split( near_tbid ,-1,1 ) djh()=split( near_DJH,-1,1 ) i_max = ubound(djh) for i = 0 to i_max if djh(i) = DJH then s_dissolve = serial(i) exit for end if next i else if instr(near_CUN, CUN_ID)0 then serial()=split( near_tbid ,-1,1 ) cun()=split( near_CUN,-1,1 ) i_max = ubound(cun) for i = 0 t

4、o i_max if cun(i) = CUN_ID then s_dissolve = serial(i) exit for end if next i else s_dissolve = tb_id endif endif （10） 將“unselected”圖層中的 tbid_dissolve 字段賦值為 tb_id： （11） 將“unselected”圖層進行備份，新圖層命名為“unselected_bak”。 （12） 使用 APPEND 工具將“selected_SpatialJoin”圖層合并到“unselected”圖層： （13） 對“unselected”圖層根據 tbi

5、d_dissolve 字段利用 Dissolve 工具進行融合，新圖 層命名為“unselected_Dissolve”： （14） 將“unselected_bak”圖層生成點圖層，命名為 “unselected_bak_FeatureToPoin”： （15） 利用 Spatial join 工具，將“unselected_bak_FeatureToPoin”圖層屬性聯(lián)接到 “unselected_Dissolve”面圖層，Match Option 選擇 CONTAINS 方式，新圖層 命名為“無碎片小班面”： 7公益林小班兌現面積平差公益林小班兌現面積平差 （1）編程實現平差思路：計算相

6、同“gyl_id”值的圖斑 shape_area 面積之和，按該 圖斑 shape_area 占相同“gyl_id”值的圖斑 shape_area 面積之和的比率，進行兌現面積平差。 （2）增加“GylZMj”字段（雙精度型），用于計算相同“gyl_id”值圖斑 shape_area 面積之和： （3）增加“pcxs”字段（雙精度型），用于計算相同“gyl_id”值圖斑面積平差系 統(tǒng)： （4）增加“NewDxMj”字段（雙精度型），用于計算平差后的兌現面積： （5）在 ACCESS 中新建兩個模塊：“1 公益林圖斑計算面積賦值”和“2 公益林 圖斑兌現面積平差差值處理”，用于公益林小班被剖分后

7、兌現面積的平差處理。代碼如下： 1 公益林圖斑計算面積賦值 Option Compare Database Option Explicit Sub updateData() Dim cnn As ADODB.Connection Set cnn = CurrentProject.Connection Dim strsqlxxb As String Dim rsXXB As ADODB.Recordset Set rsXXB = New ADODB.Recordset Dim lngGylid As Long Dim douMj As Double strsqlxxb = SELECT gyl_

8、id, sum(Shape_Area) strsqlxxb = strsqlxxb + FROM 無碎片小班面 WHERE not gyl_id = 0 strsqlxxb = strsqlxxb + GROUP BY gyl_id strsqlxxb = strsqlxxb + ORDER BY gyl_id rsXXB.Open strsqlxxb, cnn, adOpenForwardOnly, adLockBatchOptimistic Dim intXXB As Integer Do While Not rsXXB.EOF lngGylid = rsXXB.Fields.Item(0

9、).Value douMj = rsXXB.Fields.Item(1).Value updateGylMj lngGylid, douMj rsXXB.MoveNext Loop rsXXB.Close Set rsXXB = Nothing 2 計算平差系數 updatexbpcxs 3 計算平差面積 updatexbpcmj cnn.Close Set cnn = Nothing MsgBox 公益林圖斑計算面積賦值結束！, vbOKOnly, 提示 End Sub 1 更新相同公益林圖斑計算面積之和（即計算平差系數的分母） Sub updateGylMj(gylid As Long,

10、sumMj As Double) Dim cnnXXB As New ADODB.Connection Dim cmdxxb As New ADODB.Command Set cnnXXB = CurrentProject.Connection Dim rst As New ADODB.Recordset Dim strUpdate As String strUpdate = UPDATE 無碎片小班面 SET GylZMj= + Str(sumMj) + WHERE gyl_id= + Str(gylid) With cmdxxb .CommandText = strUpdate .Comm

11、andType = adCmdUnknown .ActiveConnection = cnnXXB End With Set rst = cmdxxb.Execute cnnXXB.Close Set cmdxxb = Nothing Set cnnXXB = Nothing End Sub 2 計算平差系數 Sub updatexbpcxs() Dim cnnXXB As New ADODB.Connection Dim cmdxxb As New ADODB.Command Set cnnXXB = CurrentProject.Connection Dim rst As New ADOD

12、B.Recordset Dim strUpdate As String strUpdate = UPDATE 無碎片小班面 SET pcxs = Shape_Area/GylZMj + WHERE gyl_id 0 With cmdxxb .CommandText = strUpdate .CommandType = adCmdUnknown .ActiveConnection = cnnXXB End With Set rst = cmdxxb.Execute cnnXXB.Close Set cmdxxb = Nothing Set cnnXXB = Nothing End Sub 3 計

13、算平差面積 Sub updatexbpcmj() Dim cnnXXB As New ADODB.Connection Dim cmdxxb As New ADODB.Command Set cnnXXB = CurrentProject.Connection Dim rst As New ADODB.Recordset Dim strUpdate As String strUpdate = UPDATE 無碎片小班面 SET NewDxMj = round(pcxs*兌現面積,1) With cmdxxb .CommandText = strUpdate .CommandType = adC

14、mdUnknown .ActiveConnection = cnnXXB End With Set rst = cmdxxb.Execute cnnXXB.Close Set cmdxxb = Nothing Set cnnXXB = Nothing End Sub * 2 公益林圖斑兌現面積平差差值處理 Option Compare Database Option Explicit Sub updateData() Dim cnn As ADODB.Connection Set cnn = CurrentProject.Connection Dim strsqlxxb As String D

15、im lngGylid As Long Dim douNewdxmj As Double Dim douTbmj As Double Dim douMjc As Double Dim strStart As String strStart = Time strsqlxxb = SELECT gyl_id, sum(NewDxMj), 兌現面積 strsqlxxb = strsqlxxb + FROM 無碎片小班面 WHERE gyl_id 0 strsqlxxb = strsqlxxb + GROUP BY gyl_id, 兌現面積 strsqlxxb = strsqlxxb + ORDER

16、BY gyl_id, 兌現面積 Dim rsXXB As ADODB.Recordset Set rsXXB = New ADODB.Recordset rsXXB.Open strsqlxxb, cnn, adOpenForwardOnly, adLockBatchOptimistic Dim intXXB As Integer Do While Not rsXXB.EOF lngGylid = rsXXB.Fields.Item(0).Value douNewdxmj = Round(rsXXB.Fields.Item(1).Value, 1) douTbmj = Round(rsXXB.

17、Fields.Item(2).Value, 1) douMjc = douNewdxmj - douTbmj If douMjc 0 Then updatexxb lngGylid, douMjc End If rsXXB.MoveNext Loop rsXXB.Close Set rsXXB = Nothing cnn.Close Set cnn = Nothing MsgBox strStart + 開始， + Str(Time) + 公益林圖斑兌現面積平差差值處理結束！, vbOKOnly, 提示 End Sub 公益林圖斑兌現面積平差差值處理 Sub updatexxb(gylid A

18、s Long, mjc As Double) Dim cnnXXB As New ADODB.Connection Dim cmdxxb As New ADODB.Command Dim strUpdate As String Set cnnXXB = CurrentProject.Connection 查找面積最大圖斑 Dim rsFind As ADODB.Recordset Set rsFind = New ADODB.Recordset Dim strFind As String strFind = SELECT gyl_id, Max(NewDxMj) AS xbmjMax strF

19、ind = strFind + FROM 無碎片小班面 WHERE gyl_id= + Str(gylid) strFind = strFind + GROUP BY gyl_id ORDER BY gyl_id rsFind.Open strFind, cnnXXB, adOpenForwardOnly, adLockBatchOptimistic Dim lngGylid As Long Dim douMaxMj As Double lngGylid = rsFind.Fields.Item(0).Value douMaxMj = Round(rsFind.Fields.Item(1).Value, 1) 更新面積最大圖斑兌現面積 Dim rsM As New ADODB.Recordset strUpdate = UPDATE 無碎片小班面 SET NewDxMj= + Str(douMaxMj - mjc) + WHERE gyl_id= + Str(gylid) strUpda