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

2、、maxX、minX、maxY、minY、area_envelope、area_percentArea_percent0.3isSelected = 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 serial()=split( near_tbid ,-1,1 ) djh()=spli

3、t( 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 ielse 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 to i_max if cun(i) = CUN_ID then s_dissolve =

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

5、issolve”：（14） 將“unselected_bak”圖層生成點圖層，命名為“unselected_bak_FeatureToPoin”：（15） 利用 Spatial join 工具，將“unselected_bak_FeatureToPoin”圖層屬性聯接到“unselected_Dissolve”面圖層，Match Option 選擇 CONTAINS 方式，新圖層命名為“無碎片小班面”：7公益林小班兌現面積平差公益林小班兌現面積平差（1）編程實現平差思路：計算相同“gyl_id”值的圖斑 shape_area 面積之和，按該圖斑 shape_area 占相同“gyl_id”值的

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

7、ub 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_id, sum(Shape_Area) strsqlxxb = strsqlxxb + FROM 無碎片小班面 WHERE not gyl_i

8、d = 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).Value douMj = rsXXB.Fields.Item(1).Value updateGylMj lngGylid, douMj

9、rsXXB.MoveNext Loop rsXXB.Close Set rsXXB = Nothing 2 計算平差系數 updatexbpcxs 3 計算平差面積 updatexbpcmj cnn.Close Set cnn = Nothing MsgBox 公益林圖斑計算面積賦值結束！, vbOKOnly, 提示End Sub1 更新相同公益林圖斑計算面積之和（即計算平差系數的分母）Sub updateGylMj(gylid As Long, sumMj As Double) Dim cnnXXB As New ADODB.Connection Dim cmdxxb As New ADOD

10、B.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 .CommandType = adCmdUnknown .ActiveConnection = cnnXXB End With Set rst = cmdxx

11、b.Execute cnnXXB.Close Set cmdxxb = Nothing Set cnnXXB = NothingEnd Sub2 計算平差系數Sub updatexbpcxs() 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 pcxs = Shap

12、e_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 = NothingEnd Sub3 計算平差面積Sub updatexbpcmj() Dim cnnXXB As New ADODB.Connection Dim cmdxxb As New AD

13、ODB.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 = adCmdUnknown .ActiveConnection = cnnXXB End With Set rst = cmdxxb.Execute cnnXXB.Cl

14、ose Set cmdxxb = Nothing Set cnnXXB = NothingEnd Sub*2 公益林圖斑兌現面積平差差值處理Option Compare DatabaseOption ExplicitSub updateData() Dim cnn As ADODB.Connection Set cnn = CurrentProject.Connection Dim strsqlxxb As String Dim lngGylid As Long Dim douNewdxmj As Double Dim douTbmj As Double Dim douMjc As Doubl

15、e 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 BY gyl_id, 兌現面積 Dim rsXXB As ADODB.Recordset Set rsXXB = New ADODB.Recordset rsXXB.Ope

16、n 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.Fields.Item(2).Value, 1) douMjc = douNewdxmj - douTbmj If douMjc 0 Then updatexxb lngG

17、ylid, 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 As Long, mjc As Double) Dim cnnXXB As New ADODB.Connection Dim cmdxxb As New ADODB.Command

18、 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 strFind = strFind + FROM 無碎片小班面 WHERE gyl_id= + Str(gylid) strFind = strFind + GROUP BY gyl_i

19、d 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) strUpd